c     mcprez
c ************************************************************************
c

      subroutine mcprez(mcipts,x,v,e1,e2,e12,dx,f)
c
c     Subroutine to write out the geometry of the point and the MCMM 
c     results.
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
      parameter (mcmca2=mcmcar*(mcmcar+1)/2)
c
      dimension x(mcmcar), dx(mcmcar), f(mcmcar,mcmcar)
      dimension xpr(mcmcar)
      dimension dxpr(mcmcar)
      dimension fpr(mcmca2)
      dimension qspr(mcmics)
      dimension qdpr(mcmicd)
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
c     Define some variables
c
      mcncar = 3*mcnatm
      mcnca2 = 3*mcnatm*(3*mcnatm+1)/2
c
c  Print out the internal coordinates for the Shepard points
c
c
      if (mcimre.ge.1.and.mcipic.eq.2) then
         do j = 1,mcnesp+2
            if (j.le.mcnesp) then
               write(fu6,4000) j
            elseif (j.gt.mcnesp) then
               write(fu6,4100) j-mcnesp
            endif
            do i = 1,mcmics
               qspr(i) = qs0(i,j)
            enddo
            write(fu6,4200)
            call mcpici(fu6,mcndis,mcnans,mcnads,mcndas,
     *                  mcidis,mcians,mciads,mcidas,mcmics,qspr)
            do i = 1,mcmicd
               qdpr(i) = qd0(i,j)
            enddo
            write(fu6,4300)
            call mcpici(fu6,mcndid,mcnand,mcnadd,mcndad,
     *                  mcidid,mciand,mciadd,mcidad,mcmicd,qdpr)
         enddo
c
c  next line is added so the next time the program goes through
c  this routine it will not print this information again.
c
         mcipic = 1
      endif
 4000 format (/1x,14('*'),2x,'Electronic structure ',
     *            'theory Shepard point ',i4,2x,15('*'))
 4100 format (/1x,22('*'),2x,'SCMM point for ',
     *            'configuration ',i1,2x,23('*'))
 4200 format (/1x,'** Internal coordinates for ',
     *            'Shepard interpolation:')
 4300 format (/1x,'** Internal coordinates for ',
     *            'generalized distances:')
c
c  Print out the point number
c
      write(fu6,1000) mcipts
 1000 format (/1x,33('*'),2x,'Point',i4,2x,33('*'))
c
c  Print out the geometry in unscaled angstroms and bohrs
c
      write(fu6,1200)
      do inum=1,mcnatm
         ilab = labmc(inum)
         write(fu6,1800)inum,asymb(ilab),(x(inum*3-j)*fboan,j=2,0,-1)
      enddo
      write(fu6,1400)
      do inum=1,mcnatm
         ilab = labmc(inum)
         write(fu6,1800)inum,asymb(ilab),(x(inum*3-j),j=2,0,-1)
      enddo
 1200 format(/1x,'Atom Number',3x,'Atomic Symbol',6x,'X(angstrom)',
     *   5x,'Y(angstrom)',5x,'Z(angstrom)')
 1400 format(/1x,'Atom Number',3x,'Atomic Symbol',8x,'X(bohr)',
     *   9x,'Y(bohr)',9x,'Z(bohr)')
c
 1800 format(3x,i3,15x,a2,7x,f15.8,1x,f15.8,1x,f15.8)
c
c  Print out the internal coordinates
c
      if (mcimre.ge.1.and.mcipic.ge.1) then
         write(fu6,4200)
         call mcpici(fu6,mcndis,mcnans,mcnads,mcndas,
     *               mcidis,mcians,mciads,mcidas,mcmics,qs)
         write(fu6,4300)
         call mcpici(fu6,mcndid,mcnand,mcnadd,mcndad,
     *               mcidid,mciand,mciadd,mcidad,mcmicd,qd)
      endif
c
c  Print out the energy components
c
      write (fu6,2000)
      if (mciord.eq.0) then
         write (fu6,2100) e1,e1*fhaev,e1*fhacm,e1*fhakc
         write (fu6,2200) e2,e2*fhaev,e2*fhacm,e2*fhakc
          if (icomplex.eq.1) then
c>>>>                                                                     0529MH10
c             write (fu6,2301) e12,e12*fhaev,e12*fhacm,e12*fhakc
c
c V12 output is changed because the unit is wrong.
c
             if(e12.gt.0) then
                sqe12=sqrt(e12)
                write (fu6,2300) sqe12,sqe12*fhaev,
     &                           sqe12*fhacm,sqe12*fhakc
             else
                sqe12=sqrt(-e12)
                write (fu6,2302) sqe12,sqe12*fhaev,
     &                           sqe12*fhacm,sqe12*fhakc
             endif
 2302  format(2x,'Resonance energy (V12) ',2x,f11.7,'i',1x,f11.6,'i',1x,
     *        f11.3,'i',1x,f11.5,'i')
c<<<<                                                                     0529MH10
          else
             write (fu6,2300) e12,e12*fhaev,e12*fhacm,e12*fhakc
          endif
         write (fu6,2400) v,v*fhaev,v*fhacm,v*fhakc
      elseif (mciord.eq.1) then
         write (fu6,2100) e1,e1*fhaev,e1*fhacm,e1*fhakc
      elseif (mciord.eq.2) then
         write (fu6,2200) e2,e2*fhaev,e2*fhacm,e2*fhakc
      endif
 2000 format(/31x,'hartree',9x,'eV',8x,'cm**-1',9x,'kcal')
 2100 format(2x,'SCMM1     energy (V11) ',2x,f11.7,2x,f11.6,2x,f11.3,
     *       2x,f11.5)
 2200 format(2x,'SCMM2     energy (V22) ',2x,f11.7,2x,f11.6,2x,f11.3,
     *       2x,f11.5)
 2300 format(2x,'Resonance energy (V12) ',2x,f11.7,2x,f11.6,2x,f11.3,
     *       2x,f11.5)
 2301 format(2x,'V12**2                 ',2x,f11.7,2x,f11.6,2x,f11.3,
     *       2x,f11.5)
 2400 format(2x,'MCMM      energy (V)   ',2x,f11.7,2x,f11.6,2x,f11.3,
     *       2x,f11.5)
c
c     Print out the matrix elements of the electronically diabatic
c     Hamiltonian and the lowest eigenvalue (kcal):
c
c      write (fu6,1000)
c 2500 format(2x,'MCMM Potential and Electronically Diabatic Matrix',
c     *        ' Elements (kcal/mol)')
c      write (fu6,1000) v*fhakc,e1*fhakc,e2*fhakc,e12*fhakc
c 2510 format(2x,'HOOK:',1x,'  V= ',F11.5,'  V1= ',F11.5,
c     *'  V2= ',F11.5,'  V12= ',F11.5/)
c
c
c  For gradient or Hessian calculations print the geometry and
c  the gradient in a style similar to the one in the Gaussian
c  formatted checkpoint file (in multiples of five).
c
      if (mcityp.ge.2) then
c
c  Transform the Cartesian coordinates and gradient to the printing format,
c  print the caption, and print the values in multiple of five.
c
         if (mciufo.eq.1) then
            write (fu6,2710)
            call mcpgst(fu6,x,mcncar,mcmcar)
            write (fu6,2810)
            call mcpgst(fu6,dx,mcncar,mcmcar)
         elseif (mciufo.eq.2) then
            do i=1,mcncar
               xpr(i) = x(i)*cmmc(i)
               dxpr(i) = dx(i)/cmmc(i)
            enddo
            write (fu6,2720)
            call mcpgst(fu6,xpr,mcncar,mcmcar)
            write (fu6,2820)
            call mcpgst(fu6,dxpr,mcncar,mcmcar)
         elseif (mciufo.eq.3) then
            do i=1,mcncar
               xpr(i) = x(i)*fboan
               dxpr(i) = dx(i)/fboan
            enddo
            write (fu6,2730)
            call mcpgst(fu6,xpr,mcncar,mcmcar)
            write (fu6,2830)
            call mcpgst(fu6,dxpr,mcncar,mcmcar)
         elseif (mciufo.eq.4) then
            do i=1,mcncar
               xpr(i) = x(i)*fboan*cmmc(i)
               dxpr(i) = dx(i)/(fboan*cmmc(i))
            enddo
            write (fu6,2740)
            call mcpgst(fu6,xpr,mcncar,mcmcar)
            write (fu6,2840)
            call mcpgst(fu6,dxpr,mcncar,mcmcar)
         endif
      endif
c
c  For Hessian calculation print the Hessian
c
      if (mcityp.eq.3.or.mcityp.eq.5) then
c
c  Create the Hessian half-matrix in the printing format, write the caption,
c  and print the Hessian elements in multiple of five.
c
         if (mciufo.eq.1) then
            do j=1,mcncar
               do i=1,j
                  fpr(i+(j-1)*j/2) = f(i,j)
               enddo
            enddo
            write (fu6,2910)
            call mcpgst(fu6,fpr,mcnca2,mcmca2)
         elseif (mciufo.eq.2) then 
            do j=1,mcncar
               do i=1,j
                  fpr(i+(j-1)*j/2) = f(i,j)/(cmmc(i)*cmmc(j))
               enddo
            enddo
            write (fu6,2920)
            call mcpgst(fu6,fpr,mcnca2,mcmca2)
         elseif (mciufo.eq.3) then
            do j=1,mcncar
               do i=1,j
                  fpr(i+(j-1)*j/2) = f(i,j)/(fboan*fboan)
               enddo
            enddo
            write (fu6,2930)
            call mcpgst(fu6,fpr,mcnca2,mcmca2)
         elseif (mciufo.eq.3) then
            do j=1,mcncar
               do i=1,j
                  fpr(i+(j-1)*j/2) = 
     *                  f(i,j)/(fboan*fboan*cmmc(i)*cmmc(j))
               enddo
            enddo
            write (fu6,2940)
            call mcpgst(fu6,fpr,mcnca2,mcmca2)
         endif
      endif
c
c
 2710 format(/,' ** Cartesian Coordinates (unscaled ',
     *         'bohrs):')
 2720 format(/,' ** Cartesian Coordinates (mass-scaled ',
     *         'bohrs):')
 2730 format(/,' ** Cartesian Coordinates (unscaled ',
     *         'angstroms):')
 2740 format(/,' ** Cartesian Coordinates (mass-scaled ',
     *         'angstroms):')
 2810 format(' ** Cartesian Gradient (hartrees per ',
     *         'unscaled bohr):')
 2820 format(' ** Cartesian Gradient (hartrees per ',
     *         'mass-scaled bohr):')
 2830 format(' ** Cartesian Gradient (hartrees per ',
     *         'unscaled angstrom):')
 2840 format(' ** Cartesian Gradient (hartrees per ',
     *         'mass-scaled angstrom):')
 2910 format(' ** Cartesian Hessian (hartrees per ',
     *         'unscaled bohr**2):')
 2920 format(' ** Cartesian Hessian (hartrees per ',
     *         'mass-scaled bohr**2):')
 2930 format(' ** Cartesian Hessian (hartrees per ',
     *         'unscaled angstrom**2):')
 2940 format(' ** Cartesian Hessian (hartrees per ',
     *         'mass-scaled angstrom**2):')
c
c
      return
      end
c ************************************************************************
c     mcptab
c ************************************************************************
c
      subroutine mcptab
c
c     Subroutine to write out a table of all the input parameters
c     This is a subroutine similar to subroutine intab in Polyrate8.5.
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'                                              0305MH08 
c     
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
c*******************************************************************************
c  Write out current date and time and then the title
c*******************************************************************************
c
c      call mcdatm(fu6)
c      do 1 i=1,5
c          if (cmctit(i).ne.' ') write(fu6,110) cmctit(i)
c 1    continue
c
c 110  format(a80)
c
c*******************************************************************************
c  Write out data read in *MCGENERAL section
c*******************************************************************************
c
      write(fu6,1000)
 1000 format(/80('-'),/10x,'MCGENERAL Section',/)
c     
c  Atomic masses
c
      write(fu6,1100)
 1100 format(2x,'Atom ',4x,
     *  'Atomic number',4x,'Atomic Symbol',4x,'Mass (amu)')
c
      do 2 i=1,mcnatm
2       write(fu6,1150)i,labmc(i),asymb(labmc(i)),ammc(i)
 1150 format(2x,i3,10x,i3,16x,a2,8x,f10.6)
c
c  Units for the geometries read in unit 84
c
      if (mciufi.eq.1) then
         write(fu6,1200)
      elseif (mciufi.eq.2) then
         write(fu6,1210)
      elseif (mciufi.eq.3) then
         write(fu6,1220)
      elseif (mciufi.eq.4) then
         write(fu6,1230)
      endif
 1200 format (2x,'The units for input geometries are unscaled ',
     *           'bohrs.')
 1210 format (2x,'The units for input geometries are mass-scaled ',
     *           'bohrs.')
 1220 format (2x,'The units for input geometries are unscaled ',
     *           'angstroms.')
 1230 format (2x,'The units for input geometries are mass-scaled ',
     *           'angstroms.')
c
c  MCMM results (geometry, gradient, Hessian) are mass-scaled
c
      if (mciufo.eq.1.or.mciufo.eq.3) then
         write(fu6,1400)
      elseif (mciufo.eq.2.or.mciufo.eq.4) then
         write(fu6,1450)
      endif
c
c 1028HL03s
 1450 format (2x,'The results will be given mass-scaled.')              1201HL03
 1400 format (2x,'The results will be given mass-unscaled.')            1201HL03
c 1028HL03e
c
c 1400 format (2x,'The results will be given mass-scaled.')
c 1450 format (2x,'The results will be given mass-unscaled.')
c
c  Reduced mass
c
      if (mciufi.eq.2.or.mciufi.eq.4.or.mciufo.eq.2.or.mciufo.eq.4)
     *   write(fu6,1500) smmc
 1500 format (2x,'The reduced mass is :',1x,f9.6,1x,'amu')
c
c  Type of calculation: MCMM or SCMM; energy, gradient, or Hessian.
c
      if (mciord.eq.0) then
         if (mcityp.eq.1) then
            write(fu6,1610)
         elseif (mcityp.eq.2) then
            write(fu6,1620)
         elseif (mcityp.eq.3) then
            write(fu6,1630)
         endif
      elseif (mciord.gt.0) then
         if (mcityp.eq.1) then
            write(fu6,1640)
         elseif (mcityp.eq.2) then
            write(fu6,1650)
         elseif (mcityp.eq.3) then
            write(fu6,1660)
         endif
      endif
c
 1610 format (2x,'MCMM energy will be calculated.')
 1620 format (2x,'MCMM gradient will be calculated.')
 1630 format (2x,'MCMM Hessian will be calculated.')
 1640 format (2x,'SCMM energy will be calculated.')
 1650 format (2x,'SCMM gradient will be calculated.')
 1660 format (2x,'SCMM Hessian will be calculated.')
c                                                                       0305MH08 
c     Write out if EE-MCMM calculation will be performed.               0305MH08
c                                                                       0305MH08
      if (mciee.eq.1) then                                              0305MH08 
         write(fu6,1710)                                                0305MH08
 1710    format (2x,'EE-MCMM calculation will be performed.')           0305MH08
         if (mccdqv.eq.1) write(fu6,1720)                               0305MH08
 1720    format (2x,'DQDPHI will be calculated.')                       0305MH08
         if (mccdqr.eq.1) write(fu6,1730)                               0305MH08
 1730    format (2x,'DQDR will be calculated.')                         0305MH08
      end if                                                            0305MH08
c
c*******************************************************************************
c  Write out data read in *MCENERGETICS section
c*******************************************************************************
c
      write(fu6,3000)
 3000 format(/80('-'),/10x,'MCENERGETICS Section',/)
c
c  Molecular mechanics energy for configuration 1(vz1), configuration 2(vz2),
c  and electronic structure theory energy difference(ediff0).
c
      write(fu6,3100)
c
c  MM energy of configuration 1 for a MCMM or a SCMM1 calculation
c
      if (mciord.eq.0.or.mciord.eq.1) then
         write(fu6,3200) vz1,vz1*fhaev,vz1*fhacm,vz1*fhakc
      endif
c
c  MM energy of configuration 2 and Energy difference for a MCMM or a 
c  SCMM2 calculation
c
      if (mciord.eq.0.or.mciord.eq.2) then
         write(fu6,3300) vz2,vz2*fhaev,vz2*fhacm,vz2*fhakc
         write(fu6,3400) ediff0,ediff0*fhaev,ediff0*fhacm,ediff0*fhakc
      endif
c
 3100 format(33x,'hartree',8x,'eV',7x,'cm**-1',8x,'kcal')
 3200 format(2x,'MM energy, configuration 1',1x,f11.7,1x,f11.6,1x,
     *       f11.3,1x,f11.5)
 3300 format(2x,'MM energy, configuration 2',1x,f11.7,1x,f11.6,1x,
     *       f11.3,1x,f11.5)
 3400 format(2x,'ES energy, difference     ',1x,f11.7,1x,f11.6,1x,
     *       f11.3,1x,f11.5)
c
c*******************************************************************************
c  Write out data read in *SYMMETRY section
c*******************************************************************************
c
c0505OT07s
      if (ipermsym.eq.0) goto 3205
      write(fu6,3001)
 3001 format(/80('-'),/10x,'SYMMETRY Section',/)
c
         write(fu6,3201) alphaV1
         write(fu6,3202) alphaV2
         write(fu6,3203) isigmav1
         write(fu6,3204) isigmav2
c      endif
c
 3201 format(2x,'ALPHA, configuration 1',3x,f6.1,1x,'kcal/mol')
 3202 format(2x,'ALPHA, configuration 2',3x,f6.1,1x,'kcal/mol')
 3203 format(2x,'SIGMA, configuration 1',3x,i4)
 3204 format(2x,'SIGMA, configuration 2',3x,i4)
 3205 continue
c0505OT07e
c*******************************************************************************
c  Write out data read in *RESONANCE section (only for MCMM calculations)
c*******************************************************************************
c
      if (mciord.eq.0) then
c
         write(fu6,4000)
c
c  Resonance energy function V12 if it is constant.
c
         if (mcimre.eq.0) then
            write(fu6,4110)
            write(fu6,4120)
            write(fu6,4130) e12ct,e12ct*fhaev,e12ct*fhacm,e12ct*fhakc
         else
c
c  Resonance energy function V12 is determined as an expansion from 
c  only one Shepard point.
c
            if (mcimre.eq.1) then
               write(fu6,4200) mcipex
            endif
c
c  System's linearity
c
            if (mcilin.eq.1) then
               write(fu6,4300)
            elseif (mcilin.eq.0) then
               write(fu6,4350)
            endif
c
c  Number of internal coordinates for interpolation
c
            write(fu6,4400) mcnics
c
c  Number of internal coordinates for generalized distances 
c
            write(fu6,4500) mcnicd
         endif
      endif
c
 4000 format(/80('-'),/10x,'RESONANCE Section',/)
 4110 format(2x,'Resonance energy function has a constant value.',/)
 4120 format(29x,'hartree',9x,'eV',8x,'cm**-1',9x,'kcal')
 4130 format(2x,'Resonance integral  ',3x,f11.7,2x,f11.6,2x,f11.3,
     *       2x,f11.5)
 4200 format(2x,'Resonance energy function is determined only from ',
     *          'expansion around ',
     *      /2x,'electronic structure theory Shepard point ',i4,'.')
 4300 format(2x,'The internal coordinates used for interpolation ',
     *          'should be appropriate for ',
     *      /2x,'a linear system.')
 4350 format(2x,'The internal coordinates used for interpolation ',
     *          'should be appropriate for ',
     *      /2x,'a nonlinear system.')
 4400 format(2x,'Number of internal coordinates for ',
     *          'Shepard interpolation: ',i4)
 4500 format(2x,'Number of internal coordinates for ',
     *          'generalized distances: ',i4)
c
c*******************************************************************************
c
      write(fu6,5000)
 5000 format(/80('-'))
c
      return
      end
c***********************************************************************
c     mcrfes
c***********************************************************************
c
      subroutine mcrfes
c
c     Subroutine to read in the input file containing the electronic
c     structure information and store it in the right arrays.
c     (Titus V Albu January 2002)
c
      implicit double precision (a-h,o-z)
CAMBP#ifdef MPI
CAMBP#     include "extra.h"
CAMBP#endif
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      include 'eemcmm.inc'                                              0305MH08
c
      dimension ishpt(mcmesp)
c
      character*256 finame
      character*7  fistat
      character*20 fstat
      logical lexit
c
      character*80 word(40)
      logical lsec,leof
c
c     Define some variables
c
      mcncar = 3*mcnatm
      lexit  = .false.
      fistat = 'old'
c
c     Specify the defaults
c
      mcnesp = 1
      mciuge = 1
      mciuen = 1
      mciugr = 1
      mciuhe = 1
      mcihfr = 1
c
c     Initialize the arrays
c
      do i=1,mcmesp
         ishpt(i)=0
         vsh(i)=0.d0
         do j=1,mcmcar
            xsh(j,i)=0.d0
            dsh(j,i)=0.d0
            do k=1,mcmcar
               hsh(k,j,i)=0.d0
            enddo
         enddo
      enddo
c
c     Open the input file that contains the electronic structure 
c     information
c
c      finame = 'esp.fu83'
CAMBP#ifdef MPI
CAMBP      if(master) then
CAMBP#endif
      call mcfset (fu83,finame)                                         0424MH08 
      call mcfope (fu83, fistat, finame, lexit)
      if (lexit) then
         write (fu6,100) 
         stop 'mcrfes 1'
      endif
CAMBP#ifdef MPI
CAMBP      end if
CAMBP#endif
c
c     Find and read in the MCGEN83 section
c
c      call mcrseg(mciuge,mciuen,mciugr,mciuhe,mcihfr)
      call mcrseg(mciuge,mciuen,mciugr,mciuhe)
c
c     Set file unit83 to the beginning
c
CAMBP#ifdef MPI
CAMBP      if(master) rewind fu83
CAMBP#else
      rewind fu83
CAMBP#endif
c                                                                       0424MH08 
c     In the EE-MCMM calculation, read in the EEGEN 83 section          0424MH08 
c                                                                       0424MH08 
      if (mciee.eq.1) then                                              0424MH08 
c                                                                       0424MH08 
c     Find and read in the EEGEN83 section                              0424MH08 
c                                                                       0424MH08 
         call eerd83                                                    0424MH08 
c                                                                       0424MH08 
c     Set file unit83 to the beginning                                  0424MH08 
c                                                                       0424MH08 
CAMBP#ifdef MPI
CAMBP      if(master) rewind fu83
CAMBP#else
      rewind fu83
CAMBP#endif
c                                                                       0424MH08 
      end if                                                            0424MH08 
c
c     Find the POINT sections which contains the electronic structure 
c     information
c
 10   call readln(fu83,word,nword,lsec,leof)
c
      if (leof) then
         do mciesp=1,mcnesp
            if (ishpt(mciesp).ne.1) then
               write (fu6,200) mciesp
               stop 'mcrfes 2'
            endif
         enddo
      else
         if (lsec .and. word(1).eq.'POINT') then
            if (nword .eq. 2) then
               mciesp = icmct(word(2))
               if (mciesp.gt.mcnesp) then
                  write (fu6,300) mciesp,mcnesp,mciesp
               endif
               ishpt(mciesp)=1
c               call mcrsep(mciesp,mciuge,mciuen,mciugr,mciuhe,mcihfr)
               call mcrsep(mciesp,mciuge,mciuen,mciugr,mciuhe)
            else
               write (fu6,400)
               stop 'mcrfes 3'
            endif
         endif
         go to 10
      endif
c
 100  format (1x,'Error opening the esp.fu83 file')
 200  format (1x,'Error: Shepard point ',i3,' is missing.')
 300  format (1x,'Warning: ',i3,' is higher than NESTSP (',i3,
     *           ') so Shepard point ',i3,' is ignored.')
 400  format (1x,'Error: Beginning of POINT Section should have ',
     *           'an argument in the esp.fu83 file.')
c
c     Close the input files esp.fu83
c
CAMBP#ifdef MPI
CAMBP      if(master) then
CAMBP#endif
      fstat = 'keep'
      call mcfclo (fu83,fstat)
CAMBP#ifdef MPI
CAMBP      end if
CAMBP#endif
c
c
      return
      end
c ***************************************************************************
c     mcrfgi
c ***************************************************************************
      subroutine mcrfgi
c
c     Subroutine to read in the input for MC-TINKER. The input is read in 
c     using the subroutine mcrlin. Parsing of information is done in a
c     separate subroutine for each section.
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'                                              0529MH10
c
      character * 80 string
c
c     initialize variables and set defaults
c
      call mcsdef
      mcipge = 0
c
c     start off by finding the first section given in the input deck
c
      call mcrlin(fu5,string,istrt,isect,iend)
c
c     error check - check that the file wasn't empty and that the 
c     first line found was the start of a section
c
      if (iend.eq.1) then
         write(fu6,1000)
 1000    format(1x,'Error:  input file was empty')
         stop 'mcrfgi 1'
      end if
c
      if (isect.ne.1) then
         write(fu6,1100)
 1100    format(1x,'Error:  first non-comment, non-blank line must be'
     *             ,' a section header that begins with a *')
         stop 'mcrfgi 2'
      end if
c
c     Call the correct routine to read in the data in each section.  
c     Control will come back here once another section header has
c     been found.  This will continue until an end-of-file mark
c     has been encoutered.
c
      do while (iend.eq.0)
         j = istrt + 1
c
c  MCGENERAL section
c
         if (string(j:j+8).eq.'mcgeneral') then
            mcipge = 1
            call mcrsge(string,iend,istrt)
c
c  MCENERGETICS section
c
         else if (string(j:j+11).eq.'mcenergetics') then
            call mcrsen(string,iend,istrt)
c
c  SYMMETRY section                                                     1106OT06
c                                                                       1106OT06
         else if (string(j:j+7).eq.'symmetry') then                     1106OT06
            call mcrssy(string,iend,istrt)                              1106OT06
c
c  RESONANCE section
c
         else if (string(j:j+8).eq.'resonance') then
            call mcrsre(string,iend,istrt)
c                                                                       0305MH08
c  EEGENERAL section                                                    0305MH08
c                                                                       0305MH08
         else if (string(j:j+8).eq.'eegeneral') then                    0305MH08
            call eerd85(string,iend,istrt)                              0305MH08
c                                                                       0305MH08
c  SIMULATION section                                                   0305MH08
c                                                                       0305MH08
         else if (string(j:j+9).eq.'simulation') then                   0305MH08
            call mcrsml(string,iend,istrt)                              0305MH08
c
         else
            write(fu6,1200) string(j-1:80)
            stop 'mcrfgi 3'
         end if
      end do
c
 1200 format(1x,'Error: the following is not a valid section name ',
     *          'in MC-TINKER',/A80/)
c
      if (mcipge.eq.0) then
         write(fu6,2000)
         stop 'mcrfgi 4'
      endif
 2000 format(1x,'Error: MCGENERAL section and MCATOMS keyword are ',
     *          'required in MC-TINKER.')
c
      if(mciee.eq.1.and.menicz.ne.0) call eestiz                        0529MH10
c
      return
      end
c***********************************************************************
c     mcrfmm
c***********************************************************************
c
      subroutine mcrfmm(itp,iconf)
c
c     This subroutine reads the geometries from units 81-82 and store
c     the information. It is a modified version of subroutine setup in
c     Tinkerate.
c     (Titus V Albu January 2002)
c
      implicit double precision (a-h,o-z)
C
CAMBP#ifdef MPI
CAMBP#     include "extra.h"
CAMBP#endif
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      include 'eemcmm.inc'                                              0305MH08
c
c
      real*8 xtemp(mcmcar)
      integer itagt(mcmatm),itypt(mcmatm),insv(mcmatm),
     *                  icont(mcmatm,mcmatm)
      character*3 atnamt(mcmatm)
      character*80 inklin(mcmkey)
c
      character*256 finame
      character*7  fistat
      character*20 fstat
      logical lexit
c
c     Initialize variables
c
      do i=1,mcmcar
        xtemp(i)=0.
      enddo
c
      do i=1,mcmatm
        itags(i,itp,iconf)=0
        itype(i,itp,iconf)=0
        do k=1,mcmatm
           icon12(i,k,itp,iconf)=0
        enddo
      enddo
c
      do j=1,mcmkey
        inklin(j) = ' '
      enddo
c
      lexit  = .false.
      fistat = 'old'
      if (itp.eq.1.and.iconf.eq.1.or.itp.eq.2
     *  .and.iconf.eq.1) then
      iunitr = 80+itp
      else if (itp.eq.1.and.iconf .eq. 2) then
      iunitr =72
      else if (itp.eq.1.and.iconf .eq. 3) then
      iunitr =73
      else if (itp.eq.1.and.iconf .eq. 4) then
      iunitr =74
      else if (itp.eq.1.and.iconf .eq. 5) then
      iunitr =75
      else if (itp.eq.1.and.iconf .eq. 6) then
      iunitr =76
      else if (itp.eq.2.and.iconf .eq. 2) then
      iunitr =62
      else if (itp.eq.2.and.iconf .eq. 3) then
      iunitr =63
      else if (itp.eq.2.and.iconf .eq. 4) then
      iunitr =64
      else if (itp.eq.2.and.iconf .eq. 5) then
      iunitr =65
      else if (itp.eq.2.and.iconf .eq. 6) then
      iunitr =66
      endif
c
      call mcfset(iunitr,finame)                                        0424MH08
c
c     Open the input file
c
c      if (itp.eq.1 .and. iconf .eq. 1) then 
c         finame = 'esp.fu81'
c      else if (itp.eq.1 .and. iconf .eq. 2) then
c         finame = 'esp.fu72'
c      else if (itp.eq.1 .and. iconf .eq. 3) then
c         finame = 'esp.fu73'
c      else if (itp.eq.1 .and. iconf .eq. 4) then
c         finame = 'esp.fu74'
c      else if (itp.eq.1 .and. iconf .eq. 5) then
c         finame = 'esp.fu75'
c      else if (itp.eq.1 .and. iconf .eq. 6) then
c         finame = 'esp.fu76'
c      else if (itp.eq.2.and. iconf .eq.1) then
c         finame = 'esp.fu82'
c      else if (itp.eq.2.and. iconf .eq.2) then
c         finame = 'esp.fu62'
c      else if (itp.eq.2.and. iconf .eq.3) then
c         finame = 'esp.fu63'
c      else if (itp.eq.2.and. iconf .eq.4) then
c         finame = 'esp.fu64'
c      else if (itp.eq.2.and. iconf .eq.5) then
c         finame = 'esp.fu65'
c      else if (itp.eq.2.and. iconf .eq.6) then
c         finame = 'esp.fu66'
c      endif
c
CAMBP#ifdef MPI
CAMBP      if(master) then
CAMBP#endif
c
      call mcfope (iunitr, fistat, finame, lexit)
      if (lexit) then
         write (fu6,100) itp
         stop 'mcrfmm 1'
      endif
 100  format (1x,'Error opening the esp.fu8',i1,' file')
c
CAMBP#ifdef MPI
CAMBP      end if
CAMBP#endif
c
c     Call readfile for reading the geometry and other MM information
c 
      call readfile(iunitr,mcmatm,mcmcar,xtemp,
     *              insv,itagt,itypt,icont,atnamt,
     *              mcmkey,inkey,inklin)
c
c     Store MM information and the geometry on xrc
c
      do j=1,mcnatm
         itags(j,itp,iconf)=itagt(j)
         itype(j,itp,iconf)=itypt(j)
         atname(j,itp,iconf)=atnamt(j)
         incon(j,itp,iconf)=insv(j)
         do l=1,mcnatm
            icon12(l,j,itp,iconf)=icont(l,j)
         enddo
         do l=1,3
            xrc((j-1)*3+l,itp)=dble(xtemp((j-1)*3+l))/fboan
         enddo
      enddo
c
      inky(itp,iconf)=inkey
      do j=1,inkey
         inkl(j,itp,iconf)=inklin(j)
      enddo
c                                                                       0305MH08
c     read EE-MCMM information                                          0305MH08
c                                                                       0305MH08
      if(mciee.eq.1) call eeread(iunitr,itp)                            0305MH08
c
c     Close the input file
c
      fstat = 'keep'
      call mcfclo (iunitr,fstat)
c
c
      return
      end
c ************************************************************************
c     mcrkat
c ************************************************************************
c
      subroutine mcrkat(string,istrt)
c
c     This is a modified version of the subroutine ratoms in Polyrate
c     that reads in atom labels and possible the masses.  If the
c     masses are not present then they will be looked up in a table of
c     the most common isoptopes (ams).
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
      character * 80 string
      character * 2 asymb(103)
      dimension ams(103)
c
c     array of atomic masses
c
      data (ams(i),i=1,54)  /
     *   1.007825d+00,4.0026d+00,7.01600d+00,9.01218d+00,11.00931d+00,
     *   12.0d+00,14.00307d+00,15.99491d+00,18.99840d+00,19.99244d+00,
     *   22.9898d+00,23.98504d+00,26.98153d+00,27.97693d+00,
     *   30.97376d+00,31.97207d+00,34.96885d+00,39.948d+00,
     *   38.96371d+00,39.96259d+00,44.95592d+00,47.90d+00,50.9440d+00,
     *   51.9405d+00,54.9381d+00,55.9349d+00,58.9332d+00,57.9353d+00,
     *   62.9298d+00,63.9291d+00,68.9257d+00,73.9219d+00,74.9216d+00,
     *   79.9165d+00,78.9183d+00,83.9115d+00,
     *   84.9117d+00,87.9056d+00,89.9054d+00,89.9043d+00,92.9060d+00,
     *   97.9055d+00,97.0d+00,101.9037d+00,102.9048d+00,105.9032d+00,
     *   106.9041d+00,113.9036d+00,114.9041d+00,119.9022d+00,
     *   120.9038d+00,129.9067d+00,126.9044d+00,131.9042d+00/
      data (ams(i),i=55,103)  /
     *   132.9054d+00,137.9052d+00,138.9063d+00,139.9054d+00,
     *   140.9076d+00,141.9077d+00,144.9127d+00,151.9197d+00,
     *   152.9212d+00,157.9241d+00,158.9253d+00,163.9292d+00,
     *   164.9303d+00,165.9303d+00,168.9342d+00,173.9389d+00,
     *   174.9408d+00,179.9465d+00,180.9480d+00,183.9509d+00,
     *   186.9557d+00,191.9615d+00,192.9629d+00,194.9648d+00,
     *   196.9665d+00,201.9706d+00,
     *   204.9744d+00,207.9766d+00,208.9804d+00,208.9824d+00,
     *   209.9871d+00,222.0176d+00,
     *   223.0197d+00,226.0254d+00,
     *   227.0278d+00,232.0381d+00,231.0359d+00,238.0508d+00,
     *   237.0482d+00,244.0642d+00,243.0614d+00,247.0703d+00,
     *   247.0703d+00,251.0796d+00,252.0829d+00,257.0751d+00,
     *   258.0986d+00,259.1009d+00,260.1053d+00/
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
c     read in each line in this set until an 'end' is found.  For
c     each line check if the atomic name or number is given.  If
c     an associated mass is not give assign the atom the mass of
c     the most common isotope.
c
      itot = 1
      call mcrlin(fu5,string,istrt,isect,iend)
      do while (string(istrt:istrt+2).ne.'end')
c
c         first read in atom number
c
        ib = istrt
        call rword(string,istrt,ierr)
        ie = istrt - 1
        iatm = icmct(string(ib:ie))
c
c              See if the first non-blank character is numeric; if so
c              assume atomic number was given.
c
         j = ichar(string(istrt:istrt)) - ichar('0')
         if (j.ge.0.and.j.le.9) then
             labmc(iatm) = icmct(string(istrt:80))
c
c              check that atomic number is less than or equal to 103
c
             if (labmc(iatm).le.0.or.labmc(iatm).gt.103) then
                write(fu6,1100)labmc(iatm),string
 1100           format(3x,'Incorrect atomic number:  ',i2,
     *             ' determined from the following line in file 5:'
     *             /1x,a80)
             end if
         else
c
c           for non-numeric assume it is the atomic symbol
c
             nfind = 0
             i = 1
             do while(nfind.eq.0.and.i.le.103)
               if (string(istrt:istrt+1).eq.asymb(i)) then
                   labmc(iatm) = i
                   nfind = 1
               end if
               i = i+1
             end do
c
             if (nfind.eq.0) then 
                write(fu6,1200)string(istrt:istrt+1)
                stop 'mcrkat 1'
             end if
 1200        format(3x,'ERROR: illegal atomic symbol: ',A2)
         end if
c
c        find atomic masses -  search for mass after end of label
c
         call rword(string,istrt,ierr)
         if (ierr.eq.1) then
             ammc(iatm) = ams(labmc(iatm))
         else
             ammc(iatm) = cfmct(string(istrt:80))
         end if
c
c        read in next atom
c
         itot = itot+1
         call mcrlin(fu5,string,istrt,isect,iend)
      end do
c
c     set number of atoms variable
c
      mcnatm = itot - 1
c
c     check if the number of atoms is larger than dimension statement
c
      if (mcnatm.gt.mcmatm) then
         write (fu6,1300)
         stop 'mcrkat 2'
      endif
 1300 format (2x,'Error: the number of atoms is larger than the ',
     *           'maximum number allowed.',
     *       /2x,'Increase maxatm in mcparm.i and recompile.')
c
      return
      end
c***********************************************************************
c     mcrkeh
c***********************************************************************
c
c      subroutine mcrkeh(mciesp,mciuhe,mcihfr)
      subroutine mcrkeh(mciesp,mciuhe)
c
c     Subroutine to read in the Hessian elements in the input file
c     containing the electronic structure information.
c     (Titus V Albu January 2002)
c
      implicit double precision (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
      character*80 word(40)
      logical lsec,leof
c                                                                       0305MH08 
c     for gamess hessian file                                           0305MH08 
c                                                                       0305MH08 
      if (mcihfr.eq.3) goto 1000                                        0305MH08 
c
c     Define some variables
c
      mcncar = 3*mcnatm
      lsec = .false.
      leof = .false.
c
      nk = 0
      nj = 1
c
 10   call readln(fu83,word,nword,lsec,leof)
c
      if (word(1).ne.'END') then
         do 20 ni = 1,nword
            nk = nk + 1
c
c     If the hessian is in packed form
c
            if (mcihfr.eq.1) then
               if (nk.gt.nj) then
                  nj = nj + 1
                  nk = 1
               endif
               if (nj.gt.mcncar) then
                  write(fu6,200) mciesp
                  stop 'mcrkeh 1'
               endif
               hsh(nj,nk,mciesp) = cfmct(word(ni))
               if (mciuhe.eq.2) then
                  hsh(nj,nk,mciesp)=hsh(nj,nk,mciesp)*fboan*fboan/fhakc
               endif
               hsh(nk,nj,mciesp) = hsh(nj,nk,mciesp)
c
c     If the hessian is in full form
c
            elseif (mcihfr.eq.2) then
               if(nk.gt.mcncar) then
                  nj = nj + 1
                  nk = 1
               endif
               if(nj.gt.mcncar) then
                  write(fu6,200) mciesp
                  stop 'mcrkeh 2'
               endif
               hsh(nj,nk,mciesp) = cfmct(word(ni))
               if (mciuhe.eq.2) then
                  hsh(nj,nk,mciesp)=hsh(nj,nk,mciesp)*fboan*fboan/fhakc
               endif
c
c     If no hessians are used
c
            elseif (mcihfr.eq.0.or.mcihfr.eq.4) then
c
c     skip HESSIAN-END section
c
               word(1)=''
               do while (word(1).ne.'END')                              0304MH10
                  call readln(fu83,word,nword,lsec,leof)                0304MH10
               end do                                                   0304MH10
               goto 50
c
            endif
 20      continue
      else
         if(nj.ne.mcncar.or.nk.ne.mcncar) then
            write(fu6,100) mciesp
            stop 'mcrkeh 3'
         else
            goto 50
         endif
      endif
c
      goto 10
c
 100  format (1x,'Error: Not enough numbers entered for the ',
     *           'Hessian of the Shepard point ',i3)
 200  format (1x,'Error: Too many numbers entered for the ',
     *           'Hessian of the Shepard point ',i3)
c
 50   return
c                                                                       0305MH08 
c     for gamess hessian file                                           0305MH08 
c                                                                       0305MH08 
 1000 continue                                                          0305MH08 
c                                                                       0305MH08 
      mcncar = 3*mcnatm                                                 0305MH08 
c
CAMBP#ifdef MPI
CAMBP      if(master) then
CAMBP#endif
c                                                                       0305MH08 
      do 1100 i = 1,mcncar                                              0305MH08 
         imax = 0                                                       0305MH08 
 1110    continue                                                       0305MH08 
         imin = imax+1                                                  0305MH08 
         imax = imax+5                                                  0305MH08 
         if(imax .gt. mcncar) imax = mcncar                             0305MH08 
         read(fu83,9999,err=1500)                                       0305MH08 
     &        itmp,jtmp,(hsh(i,j,mciesp),j=imin,imax)                   0305MH08 
         if(imax .lt. mcncar) go to 1110                                0305MH08 
 1100 continue                                                          0305MH08 
c                                                                       0305MH08 
 9999 format(I2,I3,5E15.8)                                              0305MH08 
c
CAMBP#ifdef MPI
CAMBP      end if
CAMBP#endif
c                                                                       0305MH08 
      call readln(fu83,word,nword,lsec,leof)
      if (word(1) .ne. 'END') then
         write(fu6,9998)
         stop 'mcrkeh 5'
 9998    format (1x,'Error in reading HESSIAN keyword')
      end if
c
CAMBP#ifdef MPI
CAMBP      call mpi_bcast(hsh,mcmcar*mcmcar*mcmesp,
CAMBP     &               mpi_double_precision,0,commsander,ier) 
CAMBP#endif
c
      return                                                            0305MH08 
c                                                                       0305MH08 
 1500 write(fu6,9997)                                                   0305MH08 
      stop 'mcrkeh 4'                                                   0305MH08 
 9997 format (1x,'Error in reading Hessian with GAMESS format')         0305MH08 
c
      end
c ***************************************************************************
c     mcrkti
c ***************************************************************************
c
      subroutine mcrkti(string,istrt)
c
c     This is a modified version of the subroutine rtitle in Polyrate
c     that reads in the title of the run.  This is in the general section of
c     the input under the keyword mctitle.  Since mctitle is a list variable
c     the input under mctitle must end with an 'end'.  Due to limitations in
c     the dimension the mctitle is restricted to 5 lines.
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
      character * 80 string
      character*80  word(40)
      logical  lsec,leof
c
c     stub for testing:
c
      i = 1
100   call rdln(fu5,word,nword,lsec,leof,string)
      if (i .le. 5 .and. word(1) .ne. 'END') then
         cmctit(i) = string
         i = i + 1
         goto 100
      endif
c
      if (i .gt. 5 .and. word(1) .ne. 'END') then
         write(fu6,1000)
         stop 'mcrkti 1'
      endif
c
1000  format('The MCTITLE section can only have 5 or less lines, ',
     *       'and should end with an END.')
c  
      return
      end
c***********************************************************************
c     mcrseg
c***********************************************************************
c
c      subroutine mcrseg(mciuge,mciuen,mciugr,mciuhe,mcihfr)
      subroutine mcrseg(mciuge,mciuen,mciugr,mciuhe)
c
c     Subroutine to read in the MCGEN83 section of the input file 
c     containing the electronic structure information.
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'                                              0305MH08 
c
      character*80 word(40)
      logical lsec,leof
c
c     Define some variables
c
      lsec = .false.
      leof = .false.
c
c     Find the MCGEN83 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 'mcrseg 1'
      endif
      if (.not. lsec .or. word(1) .ne. 'MCGEN83') 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     NESTSP
c
         if (word(1) .eq. 'NESTSP') then
            if (nword .eq. 2) then
               mcnesp = icmct(word(2))
            else
               write (fu6,300)
               stop 'mcrseg 2'
            endif
            if (mcnesp.le.0) then
               write (fu6,320)
               stop 'mcrseg 3'
            elseif (mcnesp.gt.mcmesp) then
               write (fu6,340)
               stop 'mcrseg 4'
            endif
 300  format (1x,'Error in the argument of NESTSP keyword')
 320  format (1x,'Error in the number of electronic structure ',
     *           'theory Shepard points.')
 340  format (1x,'Error in the number of electronic structure ',
     *           'theory Shepard points.',
     *       /1x,'NESTSP argument is greater than the maximum ',
     *           'number allowed: mcmesp.',
     *       /1x,'Increase mcmesp in the include file mcparm.inc ',
     *           'and recompile.')
c
c     UNITGEOM
c
         elseif (word(1) .eq. 'UNITGEOM') then
            if (nword .eq. 2) then
               if (word(2) .eq. 'BOHR') then
                  mciuge = 1
               elseif (word(2) .eq. 'ANG') then
                  mciuge = 2
               else
                  write (fu6,400)
                  stop 'mcrseg 5'
               endif
            else
               write (fu6,400)
               stop 'mcrseg 6'
            endif
 400  format (1x,'Error in the argument of UNITGEOM keyword')
c
c     UNITENER
c
         elseif (word(1) .eq. 'UNITENER') then
            if (nword .eq. 2) then
               if (word(2) .eq. 'HARTREE') then
                  mciuen = 1
               elseif (word(2) .eq. 'KCAL') then
                  mciuen = 2
               else
                  write (fu6,500)
                  stop 'mcrseg 7'
               endif
            else
               write (fu6,500)
               stop 'mcrseg 8'
            endif
 500  format (1x,'Error in the argument of UNITENER keyword')
c
c     UNITGRAD
c
         elseif (word(1) .eq. 'UNITGRAD') then
            if (nword .eq. 2) then
               if (word(2) .eq. 'HPERB') then
                  mciugr = 1
               elseif (word(2) .eq. 'KCPERA') then
                  mciugr = 2
               else
                  write (fu6,600)
                  stop 'mcrseg 9'
               endif
            else
               write (fu6,600)
               stop 'mcrseg 10'
            endif
 600  format (1x,'Error in the argument of UNITGRAD keyword')
c
c     UNITHESS
c
         elseif (word(1) .eq. 'UNITHESS') then
            if (nword .eq. 2) then
               if (word(2) .eq. 'HPERB2') then
                  mciuhe = 1
               elseif (word(2) .eq. 'KCPERA2') then
                  mciuhe = 2
               else
                  write (fu6,700)
                  stop 'mcrseg 11'
               endif
            else
               write (fu6,700)
               stop 'mcrseg 12'
            endif
 700  format (1x,'Error in the argument of UNITHESS keyword')
c
c     FORMHESS
c
         elseif (word(1) .eq. 'FORMHESS') then
            if (nword .eq. 2) then
               if (word(2) .eq. 'ZERO') then
                  mcihfr = 0
               elseif (word(2) .eq. 'PACKED') then
                  mcihfr = 1
               elseif (word(2) .eq. 'FULL') then
                  mcihfr = 2
               elseif (word(2) .eq. 'GAMESS') then                      0305MH08 
                  mcihfr = 3                                            0305MH08 
               elseif (word(2) .eq. 'NOHESS') then
                  mcihfr = 4
               else
                  write (fu6,800)
                  stop 'mcrseg 13'
               endif
            else
               write (fu6,800)
               stop 'mcrseg 14'
            endif
 800  format (1x,'Error in the argument of FORMHESS keyword')
c
c     Stop if the keyword is not recognized
c
         else
            write(fu6,900) word(1)
            stop 'mcrseg 15'
         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     mcrsen
c ***************************************************************************
c
      subroutine mcrsen(string,iend,istrt)
c
c     subroutine to read in the input in the MCENERGETICS section of 
c     MC-TINKER.
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
      character * 80 string
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 ZERO1
c
         if (string(istrt:istrt+4).eq.'zero1') then
            call rword(string,istrt,ierr)
            if (ierr.ne.1) then
               vz1 = cfmct(string(istrt:80))
            else
               write(fu6,1100)
               stop 'mcrsen 1'
            end if
 1100 format (1x,'Error: Keyword ZERO1 must have an argument.')
c
c ZERO2
c
         else if (string(istrt:istrt+4).eq.'zero2') then
            call rword(string,istrt,ierr)
            if (ierr.ne.1) then
               vz2 = cfmct(string(istrt:80))
            else
               write(fu6,1200)
               stop 'mcrsen 2'
            end if
 1200 format (1x,'Error: Keyword ZERO2 must have an argument.')
c
c EDIFF
c
         else if (string(istrt:istrt+4).eq.'ediff') then
            call rword(string,istrt,ierr)
            if (ierr.ne.1) then
               ediff0 = cfmct(string(istrt:80))
            else
               write(fu6,1300)
               stop 'mcrsen 3'
            end if
 1300 format (1x,'Error: Keyword EDIFF must have an argument.')
c
         else
            write(fu6,2000) string(istrt:80)
            stop
         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 MCENERGETICS section:',/a80)
c
      return
      end
c ***************************************************************************
c     mcrssy
c ***************************************************************************
c
      subroutine mcrssy(string,iend,istrt)
c
c     subroutine to read in the input in the SYMMETRY section of
c     MC-TINKER (O.T. March 2007).
c
      implicit double precision (a-h,o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      character * 80 string
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 ALPHA1
         if (string(istrt:istrt+6).eq.'alpha1') then
            call rword(string,istrt,ierr)
            if (ierr.ne.1) then
               alphaV1 = cfmct(string(istrt:80))
            else
               write(fu6,1301)
               stop 'mcrsen 3'
            end if
 1301 format (1x,'Error: Keyword ALPHA1 must have an argument.')
c ALPHA2
         else if (string(istrt:istrt+6).eq.'alpha2') then
            call rword(string,istrt,ierr)
            if (ierr.ne.1) then
               alphaV2 = cfmct(string(istrt:80))
            else
               write(fu6,1302)
               stop 'mcrsen 3'
            end if
 1302 format (1x,'Error: Keyword ALPHA2 must have an argument.')
c SIGMA1
         else if (string(istrt:istrt+6).eq.'sigma1') then
            call rword(string,istrt,ierr)
            if (ierr.ne.1) then
               isigmav1  = cfmct(string(istrt:80))
            else
               write(fu6,1303)
               stop 'mcrsen 3'
            end if
 1303 format (1x,'Error: Keyword SIGMA1 must have an argument.')
c SIGMA2
         else if (string(istrt:istrt+6).eq.'sigma2') then
            call rword(string,istrt,ierr)
            if (ierr.ne.1) then
               isigmav2  = cfmct(string(istrt:80))
            else
               write(fu6,1304)
               stop 'mcrsen 3'
            end if
 1304 format (1x,'Error: Keyword SIGMA2 must have an argument.')
c IPERMSYM
         else if (string(istrt:istrt+6).eq.'permsym') then
            call rword(string,istrt,ierr)
            if (ierr.ne.1) then
               ipermsym = cfmct(string(istrt:80))
                 if (ipermsym.ne.1.and.ipermsym.ne.0) then
                   write (fu6,1306) 
                   stop 'mcrsen 3'
                 endif
            else
               write(fu6,1305)
               stop 'mcrsen 3'
            end if
 1305 format (1x,'Error: Keyword PERMSYM must have an argument.')
 1306 format (1x,'Error: Keyword PERMSYM must have an argument 1 or 0.')
         else
            write(fu6,2001) string(istrt:80)
            stop
         end if
         call mcrlin(fu5,string,istrt,isect,iend)
      end do
c
 2001 format(1x,'Error: the following is not a valid keyword in ',
     *          'the SYMMETRY section:',/a80)
c
      return
      end
c***********************************************************************
c     mcrsep
c***********************************************************************
c
c      subroutine mcrsep(mciesp,mciuge,mciuen,mciugr,mciuhe,mcihfr)
      subroutine mcrsep(mciesp,mciuge,mciuen,mciugr,mciuhe)
c
c     Subroutine to read in the POINT sections of the input file 
c     containing the electronic structure information.
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 =========================
CAMBP#     include "parallel.h"
CAMBP#     include "extra.h"
CAMBP#endif
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      include 'eemcmm.inc'                                              0305MH08 
c
      character*80 word(40)
      logical lsec,leof
c
      dimension mcidiz(2,mcmics),mcianz(3,mcmics)                       0529MH10 
      dimension mciadz(3,mcmics),mcidaz(4,mcmics)                       0529MH10 
      dimension mcpdum(mcmics)                                          0529MH10 
c
c     Define some variables
c
      mcncar = 3*mcnatm
      lsec = .false.
      leof = .false.
c
      igeom = 0
      iener = 0
      igrad = 0
      ihess = 0
      if(mcihfr.eq.0) ihess=1                                           0305MH10 
c
      iqphi = 0                                                         0305MH08 
      idqdv = 0                                                         0305MH08 
      if(mcifqv.eq.0) idqdv=1                                           0305MH10 
      idqdr = 0                                                         0305MH08 
      if(mcifqr.eq.0) idqdr=1                                           0305MH10 
c
      mcnzrh(mciesp)=0                                                  0529MH10 
      mcnzrc(mciesp)=0                                                  0529MH10 
      mcnzra(mciesp)=0                                                  0529MH10 
c
c     Read the keywords
c
 10   call readln(fu83,word,nword,lsec,leof)
      if (.not. lsec .and. .not. leof) then
c
c     GEOMETRY
c
         if (word(1) .eq. 'GEOMETRY') then
            igeom = 1
CAMBP#ifdef MPI
CAMBP            if(master) read (fu83,*) (xsh(i,mciesp),i=1,mcncar)
CAMBP            call mpi_bcast(xsh, mcmcar*mcmesp, mpi_double_precision,
CAMBP     &                     0, commsander, ier) 
CAMBP#else
            read (fu83,*) (xsh(i,mciesp),i=1,mcncar)
CAMBP#endif
            call readln(fu83,word,nword,lsec,leof)
            if (word(1).ne.'END') then
               write(fu6,100) mciesp
               stop 'mcrsep 1'
            endif
            if (mciuge.eq.2) then
               do i=1,mcncar
                  xsh(i,mciesp)=xsh(i,mciesp)/fboan
               enddo
            endif
 100  format (1x,'Error in reading GEOMETRY keyword for ',
     *           'Shepard point ',i3)
c
c     ENERGY
c
         elseif (word(1) .eq. 'ENERGY') then
            iener = 1
            if (nword .eq. 2) then
               vsh(mciesp) = cfmct(word(2))
               if (mciuen.eq.2) then
                  vsh(mciesp) = vsh(mciesp)/fhakc
               endif
            else
               write (fu6,200)
               stop 'mcrsep 2'
            endif
 200  format (1x,'Error in the argument of ENERGY keyword for ',
     *           'Shepard point ',i3)
c
c     GRADIENT
c
         elseif (word(1) .eq. 'GRADIENT') then
            igrad = 1
CAMBP#ifdef MPI
CAMBP            if(master) read (fu83,*) (dsh(i,mciesp),i=1,mcncar)
CAMBP            call mpi_bcast(dsh, mcmcar*mcmesp, mpi_double_precision,
CAMBP     &                     0, commsander, ier) 
CAMBP#else
            read (fu83,*) (dsh(i,mciesp),i=1,mcncar)
CAMBP#endif
            call readln(fu83,word,nword,lsec,leof)
            if (word(1).ne.'END') then
               write(fu6,300) mciesp
               stop 'mcrsep 3'
            endif
            if (mciugr.eq.2) then
               do i=1,mcncar
                  dsh(i,mciesp)=dsh(i,mciesp)*fboan/fhakc
               enddo
            endif
cOT
 300  format (1x,'Error in reading GRADIENT keyword for ',
     *           'Shepard point ',i3)
c
c     HESSIAN
c
         elseif (word(1) .eq. 'HESSIAN') then
            ihess = 1
c            call mcrkeh(mciesp,mciuhe,mcihfr)
             call mcrkeh(mciesp,mciuhe)
c                                                                       0305MH08 
c     QPHI, DQDPHI, DQDR                                                0305MH08 
c                                                                       0305MH08 
         elseif (word(1) .eq. 'QPHI'   ) then                           0305MH08 
            call eerqps(mciesp)                                         0305MH08 
           iqphi = 1                                                    0305MH08 
         elseif (word(1) .eq. 'DQDPHI' ) then                           0305MH08 
            call eerdps(mciesp)                                         0305MH08 
            idqdv = 1                                                   0305MH08 
         elseif (word(1) .eq. 'DQDR'   ) then                           0305MH08 
            call eerdrs(mciesp)                                         0305MH08 
            idqdr = 1                                                   0305MH08 
c>>>>                                                                   0529MH10
         elseif (word(1) .eq. 'ICSHZERO') then  
c
            call mcrkic(fu83,fu6,mcmatm,mcmics,mcnzrh(mciesp),
     *                  mcndiz,mcnanz,mcnadz,mcndaz,
     *                  mcidiz,mcianz,mciadz,mcidaz,
     *                  mcsdum,mcpdum)
c
            call mcishz(mcizrh(1,mciesp),mcndiz,mcnanz,mcndaz,mcnadz,
     &                  mcidiz,mcianz,mcidaz,mciadz)
c
c
c
         elseif (word(1) .eq. 'ICSCZERO') then  
c
            call mcrkic(fu83,fu6,mcmatm,mcmics,mcnzrc(mciesp),
     *                  mcndiz,mcnanz,mcnadz,mcndaz,
     *                  mcidiz,mcianz,mciadz,mcidaz,
     *                  mcsdum,mcpdum)
c
            call mcishz(mcizrc(1,mciesp),mcndiz,mcnanz,mcndaz,mcnadz,
     &                  mcidiz,mcianz,mcidaz,mciadz)
c
c
         elseif (word(1) .eq. 'ICSAZERO') then  
c
            call mcrkic(fu83,fu6,mcmatm,mcmics,mcnzra(mciesp),
     *                  mcndiz,mcnanz,mcnadz,mcndaz,
     *                  mcidiz,mcianz,mciadz,mcidaz,
     *                  mcsdum,mcpdum)
c
            call mcishz(mcizra(1,mciesp),mcndiz,mcnanz,mcndaz,mcnadz,
     &                  mcidiz,mcianz,mcidaz,mciadz)
c<<<<                                                                   0529MH10
c
c     Stop if the keyword is not recognized
c
         else
            write(fu6,400) word(1)
            stop 'mcrsep 4'
         endif
 400  format (1x,'Error: The following keyword is not recognized',/a80)
c
c     Read in another keyword
c
         if(mciee .eq. 0) then                                          0305MH08 
            if (igeom.eq.0.or.iener.eq.0.or.                            0305MH08 
     &          igrad.eq.0.or.ihess.eq.0) then                          0305MH08 
               goto 10                                                  0305MH08 
            endif                                                       0305MH08 
         else                                                           0305MH08 
             if (igeom.eq.0.or.iener.eq.0.or.                           0305MH08 
     &           igrad.eq.0.or.ihess.eq.0.or.                           0305MH08 
     &           iqphi.eq.0.or.idqdv.eq.0.or.                           0305MH08 
     &           idqdr.eq.0) then                                       0305MH08 
                goto 10                                                 0305MH08 
             end if                                                     0305MH08 
          end if                                                        0305MH08 
c
      else
         if (igeom.eq.0) then
            write (fu6,510) mciesp
            stop 'mcrsep 5'
         endif
         if (iener.eq.0) then
            write (fu6,520) mciesp
            stop 'mcrsep 6'
         endif
         if (igrad.eq.0) then
            write (fu6,530) mciesp
            stop 'mcrsep 7'
         endif
         if (ihess.eq.0) then
            write (fu6,540) mciesp
            stop 'mcrsep 8'
         endif
c
         if (iqphi.eq.0) then                                           0305MH08 
            write (fu6,550) mciesp                                      0305MH08 
            stop 'mcrsep 9'                                             0305MH08 
         endif                                                          0305MH08 
         if (idqdv.eq.0) then                                           0305MH08 
            write (fu6,560) mciesp                                      0305MH08 
            stop 'mcrsep 10'                                            0305MH08 
         endif                                                          0305MH08 
         if (idqdr.eq.0) then                                           0305MH08 
            write (fu6,570) mciesp                                      0305MH08 
            stop 'mcrsep 11'                                            0305MH08 
         endif                                                          0305MH08 
c
      endif
 510  format (1x,'GEOMETRY keyword is missing for Shepard point ',i3)
 520  format (1x,'ENERGY keyword is missing for Shepard point ',i3)
 530  format (1x,'GRADIENT keyword is missing for Shepard point ',i3)
 540  format (1x,'HESSIAN keyword is missing for Shepard point ',i3)
c
 550  format (1x,'QPHI keyword is missing for Shepard point ',i3)       0305MH08 
 560  format (1x,'DQDPHI keyword is missing for Shepard point ',i3)     0305MH08 
 570  format (1x,'DQDR keyword is missing for Shepard point ',i3)       0305MH08 
c
      return
      end
c***********************************************************************
c     mcrsge
c***********************************************************************
c
      subroutine mcrsge(string,iend,istrt)
c
c     subroutine to read in the input in the MCGENERAL section of 
c     MC-TINKER.
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
      character * 80 string
      mcipat = 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 MCTITLE
c
         if (string(istrt:istrt+6).eq.'mctitle') then
            call mcrkti(string,istrt)
c
c MCATOMS
c
         else if (string(istrt:istrt+6).eq.'mcatoms') then
            mcipat = 1
            call mcrkat(string,istrt)
c
c UNITINPUT
c
         else if (string(istrt:istrt+8).eq.'unitinput') then
            call rword(string,istrt,ierr)
            if(ierr.ne.1) then
                if(string(istrt:istrt+3).eq.'bohr') then
                   mciufi = 1
                elseif (string(istrt:istrt+5).eq.'msbohr') then
                   mciufi = 2
                elseif (string(istrt:istrt+2).eq.'ang') then
                   mciufi = 3
                elseif (string(istrt:istrt+4).eq.'msang') then
                   mciufi = 4
                else
                   write (fu6,1100)
                   stop 'mcrsge 1'
                endif
            else
                write(fu6,1110)
                stop 'mcrsge 2'
            endif
 1100 format (1x,'Error: Keyword UNITINPUT has a wrong argument.')
 1110 format (1x,'Error: Keyword UNITINPUT must have an argument.')
c
c UNITOUTPUT
c
         else if (string(istrt:istrt+9).eq.'unitoutput') then
            call rword(string,istrt,ierr)
            if(ierr.ne.1) then
                if(string(istrt:istrt+3).eq.'bohr') then
                   mciufo = 1
                elseif (string(istrt:istrt+5).eq.'msbohr') then
                   mciufo = 2
                elseif (string(istrt:istrt+2).eq.'ang') then
                   mciufo = 3
                elseif (string(istrt:istrt+4).eq.'msang') then
                   mciufo = 4
                else
                   write (fu6,1200)
                   stop 'mcrsge 3'
                endif
            else
                write(fu6,1210)
                stop 'mcrsge 4'
            endif
 1200 format (1x,'Error: Keyword UNITOUTPUT has a wrong argument.')
 1210 format (1x,'Error: Keyword UNITOUTPUT must have an argument.')
c
c SCMASS
c
         else if (string(istrt:istrt+5).eq.'scmass') then
            call rword(string,istrt,ierr)
            if(ierr.ne.1) then
               smmc = cfmct(string(istrt:80))
               if (smmc.le.0) then
                  write (fu6,1320)
                  stop 'mcrsge 5'
               endif
            else
               write(fu6,1310)
               stop 'mcrsge 6'
            end if
 1310 format (1x,'Error: Keyword SCMASS must have an argument.')
 1320 format (1x,'Error: Keyword SCMASS must have a positive ',
     *           'argument.')
c
c TYPECALC
c
         else if (string(istrt:istrt+7).eq.'typecalc') then
            call rword(string,istrt,ierr)
            if (ierr.ne.1) then
               if (string(istrt:istrt+5).eq.'energy') then
                  mcityp = 1
               elseif (string(istrt:istrt+7).eq.'gradient') then
                  mcityp = 2
               elseif (string(istrt:istrt+6).eq.'hessian') then
                  mcityp = 3
               elseif (string(istrt:istrt+7).eq.'gradtest') then
                  mcityp = 4
               elseif (string(istrt:istrt+7).eq.'hesstest') then
                  mcityp = 5
               elseif (string(istrt:istrt+9).eq.'chargetest') then      0227MH10 
                  mcityp = 6                                            0227MH10 
               elseif (string(istrt:istrt+9).eq.'dqdphitest') then      0227MH10 
                  mcityp = 7                                            0227MH10 
               elseif (string(istrt:istrt+7).eq.'dqdrtest') then        0227MH10 
                  mcityp = 8                                            0227MH10 
               else
                  write(fu6,1400)
                  stop 'mcrsge 7'
               endif
            else
               write(fu6,1410)
               stop 'mcrsge 8'
            endif
          else if (string(istrt:istrt+7).eq.'stepsize') then
            call rword(string,istrt,ierr)
              if (ierr.ne.1) then
               dh = cfmct(string(istrt:80))
              else
                write(fu6,1411)
                stop 'mcrsen 9'
              endif
          else if (string(istrt:istrt+7).eq.'ssweight') then
            call rword(string,istrt,ierr)
              if (ierr.ne.1) then
               hh = cfmct(string(istrt:80))
              else
                write(fu6,1412)
                stop 'mcrsen 10'
              endif
          else if (string(istrt:istrt+5).eq.'udelta') then
            call rword(string,istrt,ierr)
              if (ierr.ne.1) then
               udelta = cfmct(string(istrt:80))
              else
                write(fu6,1413)
                stop 'mcrsen 11'
              endif
          else if (string(istrt:istrt+3).eq.'unn') then
            call rword(string,istrt,ierr)
              if (ierr.ne.1) then
               unn = cfmct(string(istrt:80))
              else
                write(fu6,1414)
                stop 'mcrsen 12'
              endif
 1400 format (1x,'Error: Keyword TYPECALC has a wrong argument.')
 1410 format (1x,'Error: Keyword TYPECALC must have an argument.')
 1411 format (1x,'Error: Keyword STEPSIZE must have an argument.')
 1412 format (1x,'Error: Keyword SSWEIGHT must have an argument.')
 1413 format (1x,'Error: Keyword UDELTA must have an argument.')
 1414 format (1x,'Error: Keyword UNN must have an argument.')
c
c ORDERCALC
c
         else if (string(istrt:istrt+8).eq.'ordercalc') then
            call rword(string,istrt,ierr)
            if (ierr.ne.1) then
               if (string(istrt:istrt+3).eq.'mcmm') then
                  mciord = 0
               elseif (string(istrt:istrt+4).eq.'scmm1') then
                  mciord = 1
               elseif (string(istrt:istrt+4).eq.'scmm2') then
                  mciord = 2
               else
                  write(fu6,1500)
                  stop 'mcrsge 9'
               endif
            else
               write(fu6,1510)
               stop 'mcrsge 10'
            endif
 1500 format (1x,'Error: Keyword ORDERCALC has a wrong argument.')
 1510 format (1x,'Error: Keyword ORDERCALC must have an argument.')
c
         else
            write(fu6,2000) string(istrt:80)
            stop 'mcrsge 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 MCGENERAL section of MC-TINKER',/A80)
c
      if (mcipat.eq.0) then
         write(fu6,3000)
         stop 'mcrsge 12'
      endif
 3000 format(1x,'Error: MCATOMS keyword is required in MC-TINKER.')
c
c
      return
      end
c ***************************************************************************
c     mcrsre
c ***************************************************************************
c
      subroutine mcrsre(string,iend,istrt)
c
c     Subroutine to read in the input the RESONANCE section of MC-TINKER.
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
      character * 80 string
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 RESMETHOD
c
         if (string(istrt:istrt+8).eq.'resmethod') then
            call rword(string,istrt,ierr)
            if (ierr.ne.1) then
               if (string(istrt:istrt+7).eq.'constant') then
                  mcimre = 0
               elseif (string(istrt:istrt+8).eq.'expansion') then
                  mcimre = 1
               elseif (string(istrt:istrt+6).eq.'shepard') then
                  mcimre = 2
               else
                  write(fu6,1100)
                  stop 'mcrsre 1'
               endif
            else
               write(fu6,1110)
               stop 'mcrsre 2'
            endif
 1100 format (1x,'Error: Keyword RESMETHOD has a wrong argument.')
 1110 format (1x,'Error: Keyword RESMETHOD must have an argument.')
c
c RESVALUE
c
         else if (string(istrt:istrt+7).eq.'resvalue') then
            call rword(string,istrt,ierr)
            if(ierr.ne.1) then
               e12ct = cfmct(string(istrt:80))
            else
               write(fu6,1200)
               stop 'mcrsre 3'
            end if
 1200 format (1x,'Error: Keyword RESVALUE must have an argument.')
c
c POINTEXP
c
         else if (string(istrt:istrt+7).eq.'pointexp') then
            call rword(string,istrt,ierr)
            if (ierr.ne.1) then
               mcipex = icmct(string(istrt:80))
            else
               write(fu6,1300)
               stop 'mcrsre 4'
            end if
 1300 format (1x,'Error: Keyword POINTEXP must have an argument.')
c
c RESFORM
c
         else if (string(istrt:istrt+6).eq.'resform') then
            call rword(string,istrt,ierr)
            if (ierr.ne.1) then
               mcifre = icmct(string(istrt:80))
            else
               write(fu6,1400)
               stop 'mcrsre 5'
            end if
c
c    Check if RESFORM is not set to simple quadratic (mcifre=2).
c
            if (mcifre.ne.2) then
               write (fu6,1410)
               stop 'mcrsre 6'
            endif
 1400 format (1x,'Error: Keyword RESFORM must have an argument.')
 1410 format (1x,'Error: Only RESFORM 2 is supported in the ',
     *           'current version of MC-TINKER.')
c
c LINEARITY
c
         else if (string(istrt:istrt+8).eq.'linearity') then
            call rword(string,istrt,ierr)
            if (ierr.ne.1) then
               if (string(istrt:istrt+8).eq.'nonlinear') then
                  mcilin = 0
               elseif (string(istrt:istrt+5).eq.'linear') then
                  mcilin = 1
               else
                  write(fu6,1500)
                  stop 'mcrsre 7'
               endif
            else
               write(fu6,1510)
               stop 'mcrsre 8'
            endif
 1500 format (1x,'Error: Keyword LINEARITY has a wrong argument.')
 1510 format (1x,'Error: Keyword LINEARITY must have an argument.')
c
c PRINTIC
c
         else if (string(istrt:istrt+6).eq.'printic') then
            call rword(string,istrt,ierr)
            if (ierr.ne.1) then
               if (string(istrt:istrt+3).eq.'none') then
                  mcipic = 0
               elseif (string(istrt:istrt+4).eq.'point') then
                  mcipic = 1
               elseif (string(istrt:istrt+2).eq.'all') then
                  mcipic = 2
               else
                  write(fu6,1600)
                  stop 'mcrsre 9'
               endif
            else
               write(fu6,1610)
               stop 'mcrsre 10'
            endif
 1600 format (1x,'Error: Keyword PRINTIC has a wrong argument.')
 1610 format (1x,'Error: Keyword PRINTIC must have an argument.')
c
c ICSHEPARD
c
         else if (string(istrt:istrt+9).eq.'icshepard') then
            mcipis = 1
            call mcrkic(fu5,fu6,mcmatm,mcmics,mcnics,
     *                  mcndis,mcnans,mcnads,mcndas,
     *                  mcidis,mcians,mciads,mcidas,
     *                  mcsins,mcpnds)                                  0312MH10 
c                                            
c ICDISTANCE
c
         else if (string(istrt:istrt+9).eq.'icdistance') then
            mcipid = 1
            call mcrkic(fu5,fu6,mcmatm,mcmicd,mcnicd,
     *                  mcndid,mcnand,mcnadd,mcndad,
     *                  mcidid,mciand,mciadd,mcidad,
     *                  mcsind,mcpndd)                                  0312MH10 
c                                                                       0305MH08 
c ISHMM added by M. Higashi                                             0305MH08 
c                                                                       0305MH08 
         else if (string(istrt:istrt+4).eq.'ishmm') then                0305MH08 
            call rword(string,istrt,ierr)                               0305MH08 
            if (ierr.ne.1) then                                         0305MH08 
               if (string(istrt:istrt+3).eq.'true') then                0305MH08 
                  mcshrp = 0                                            0305MH08 
               elseif (string(istrt:istrt+4).eq.'false') then           0305MH08 
                  mcshrp = 1                                            0305MH08 
               else                                                     0305MH08 
                  write(fu6,1700)                                       0305MH08 
                  stop 'mcrsre 14'                                      0305MH08 
               endif                                                    0305MH08 
            else                                                        0305MH08 
               write(fu6,1710)                                          0305MH08 
               stop 'mcrsre 15'                                         0305MH08 
            endif                                                       0305MH08 
 1700 format (1x,'Error: Keyword ISHMM has a wrong argument.')          0305MH08 
 1710 format (1x,'Error: Keyword ISHMM must have an argument.')         0305MH08 
c                                                                       0305MH08 
c IPRWGT added by M. Higashi                                            0305MH08 
c                                                                       0305MH08 
         else if (string(istrt:istrt+5).eq.'iprwgt') then               0305MH08 
            call rword(string,istrt,ierr)                               0305MH08 
            if (ierr.ne.1) then                                         0305MH08 
               if (string(istrt:istrt+3).eq.'true') then                0305MH08 
                  mcprwg = 1                                            0305MH08 
               elseif (string(istrt:istrt+4).eq.'false') then           0305MH08 
                  mcprwg = 0                                            0305MH08 
               else                                                     0305MH08 
                  write(fu6,1800)                                       0305MH08 
                  stop 'mcrsre 16'                                      0305MH08 
               endif                                                    0305MH08 
            else                                                        0305MH08 
               write(fu6,1810)                                          0305MH08 
               stop 'mcrsre 17'                                         0305MH08 
            endif                                                       0305MH08 
 1800 format (1x,'Error: Keyword IPRWGT has a wrong argument.')         0305MH08 
 1810 format (1x,'Error: Keyword IPRWGT must have an argument.')        0305MH08 
c
c IPRCOE
c
         else if (string(istrt:istrt+5).eq.'iprcoe') then               0601MH10 
            call rword(string,istrt,ierr)                               0601MH10 
            if (ierr.ne.1) then                                         0601MH10 
               if (string(istrt:istrt+3).eq.'true') then                0601MH10 
                  mcpcoe = 1                                            0601MH10 
               elseif (string(istrt:istrt+4).eq.'false') then           0601MH10 
                  mcpcoe = 0                                            0601MH10 
               else                                                     0601MH10 
                  write(fu6,1820)                                       0601MH10 
                  stop 'mcrsre 18'                                      0601MH10 
               endif                                                    0601MH10 
            else                                                        0601MH10 
               write(fu6,1830)                                          0601MH10 
               stop 'mcrsre 19'                                         0601MH10 
            endif                                                       0601MH10 
 1820 format (1x,'Error: Keyword IPRCOE has a wrong argument.')         0601MH10 
 1830 format (1x,'Error: Keyword IPRCOE must have an argument.')        0601MH10 
c
c NONHERMITIAN
         else if (string(istrt:istrt+11).eq.'nonhermitian') then        1212OT08
            call rword(string,istrt,ierr)                               1212OT08
            if (ierr.ne.1) then                                         1212OT08
               if (string(istrt:istrt+3).eq.'true') then                1212OT08
               icomplex=1                                               1212OT08
                 elseif (string(istrt:istrt+4).eq.'false') then         1212OT08
               icomplex=0                                               1212OT08
                 else                                                   1212OT08
                   write (fu6,1307)                                     1212OT08
                   stop 'mcrsen 3'                                      1212OT08
                 endif                                                  1212OT08
            else                                                        1212OT08
               write(fu6,1308)                                          1212OT08
               stop 'mcrsen 3'                                          1212OT08
            end if                                                      1212OT08
 1308 format (1x,'Error: Keyword NONHERMITIAN must have an argument.')  1212OT08
 1307 format (1x,'Error: Keyword NONHERMITIAN must have an argument.')  1212OT08
c IJACOB                                                                1212OT08
         else if (string(istrt:istrt+8).eq.'jacobians') then            1212OT08
            call rword(string,istrt,ierr)                               1212OT08
            if (ierr.ne.1) then                                         1212OT08
               ijacob= cfmct(string(istrt:80))                          1212OT08
                 if (ijacob.ne.1.and.ijacob.ne.0) then                  1212OT08
                   write (fu6,1309)                                     1212OT08
                   stop 'mcrsen 3'                                      1212OT08
                 endif                                                  1212OT08
            else                                                        1212OT08
               write(fu6,1310)                                          1212OT08
               stop 'mcrsen 3'                                          1212OT08
            end if                                                      1212OT08
 1310 format (1x,'Error: Keyword JACOBIANS must have an argument.')     1212OT08
 1309 format ('Error:Keyword JACOBIANS must have an argument 1 or 0.')  1212OT08
c IWSCALE
         else if (string(istrt:istrt+5).eq.'wscale') then               1212OT08
            call rword(string,istrt,ierr)                               1212OT08
            if (ierr.ne.1) then                                         1212OT08
               iwscale= cfmct(string(istrt:80))                         1212OT08
                 if (iwscale.ne.1.and.iwscale.ne.0) then                1212OT08
                   write (fu6,1312)                                     1212OT08
                   stop 'mcrsen 3'                                      1212OT08
                 endif                                                  1212OT08
            else                                                        1212OT08
               write(fu6,1311)                                          1212OT08
               stop 'mcrsen 3'                                          1212OT08
            end if                                                      1212OT08
 1311 format (1x,'Error: Keyword WSCALE must have an argument.')        1212OT08
 1312 format ('Error: Keyword WSCALE must have an argument 1 or 0.')    1212OT08
c
         else
            write(fu6,2000) string(istrt:80)
            stop 'mcrsre 11'
         end if
c
         call mcrlin(fu5,string,istrt,isect,iend)
      end do
c
 2000 format(1x,'Error: the following is not a valid keyword in ',
     *          'the RESONANCE section:',/A80)
c
      if (mcimre.gt.0.and.mcipis.eq.0) then
         write(fu6,3100)
         stop 'mcrsre 12'
      endif
      if (mcimre.gt.0.and.mcipid.eq.0) then
         write(fu6,3200)
         stop 'mcrsre 13'
      endif
 3100 format(1x,'Error: Keyword ICSHEPARD is required when ',
     *          'resonance integral is not constant.')
 3200 format(1x,'Error: Keyword ICDISTANCE is required when ',
     *          'resonance integral is not constant.')
c
      return
      end
c***********************************************************************
c     mcscal
c***********************************************************************
c
      subroutine mcscal
c
c     This subroutine is the driver for preparation routines needed
c     to set the 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'                                              0305MH08
c
c     Set some variables to the values expected later in the code
c
      call mcsvar
c
c     Read the molecular mechanics information (from units 81 and 82) and
c     place it in the right arrays. 
c
c     For an MCMM calculation,call the mcsici subroutine to set the
c     internal coordinates, then read the electronic structure information
c     (from unit 83) and transform to internal coordinates only if the 
c     resonance integral is not constant.
c
c     For an MCMM calculation, then transform the molecular mechanics Shepard
c     geometry from Cartesian to internal coordinates. This should be done
c     after the electronic structure information is read in because the
c     number of electronic structure theory Shepard points should be
c     known at this point.
c
      if (mciord.eq.1) then
         call mcrfmm(1,1)
c
         if (mciee.eq.1) then                                           0305MH08
            call mcsici                                                 0305MH08
            call eetmmg(1)                                              0305MH08
            call eetiqr(1)                                              0305MH08
         endif                                                          0305MH08
c
      else if (mciord.eq.2) then
         call mcrfmm(2,1)
c
         if (mciee.eq.1) then                                           0305MH08
            call mcsici                                                 0305MH08
            call eetmmg(2)                                              0305MH08
            call eetiqr(2)                                              0305MH08
         endif                                                          0305MH08
c
c for an MCMM calculation:
      else if (mciord.eq.0) then
        if (ipermsym.eq.0) then                                         1106OT06
         call mcrfmm(1,1)
         call mcrfmm(2,1)
        else
         call mcrfmm(1,1)                                               1106OT06
         call mcrfmm(1,2)                                               1106OT06
         call mcrfmm(1,3)                                               1106OT06
         call mcrfmm(1,4)                                               1106OT06
         call mcrfmm(1,5)                                               1106OT06
         call mcrfmm(1,6)                                               1106OT06
         call mcrfmm(2,1)                                               1106OT06
         call mcrfmm(2,2)                                               1106OT06
         call mcrfmm(2,3)                                               1106OT06
         call mcrfmm(2,4)                                               1106OT06
         call mcrfmm(2,5)                                               1106OT06
         call mcrfmm(2,6)                                               1106OT06
        endif
         if (mcimre.ne.0) then
            call mcsici
c
            if (mciee.eq.1) then
               call eetmmg(1)                                           0305MH08
               call eetiqr(1)                                           0305MH08
               call eetmmg(2)                                           0305MH08
               call eetiqr(2)                                           0305MH08
            endif                    
c
            call mcsesi
          if (ipermsym.eq.0) then                                       1106OT06
            call mctmmg
          else                                                          1106OT06
            call mctmmgs                                                1106OT06
          endif
         endif
      endif
c
      return
      end
c ***************************************************************************
c     mcsdef
c ***************************************************************************
c
      subroutine mcsdef
c
c     This is the subroutine for setting the default for the parameters
c     and variables that are read in the esp.fu85 input file of MC-TINKER.
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'                                              0305MH08 
c
c ----------------------------------------------------------------------
c     MCGENERAL section
c ----------------------------------------------------------------------
c
c   MCTITLE             blank
c   MCATOMS             no defaults
c   UNITINPUT           ang
c   UNITOUTPUT          bohr
c   TYPECALC            energy
c   ORDERCALC           mcmm
c   SCMASS              smmc
c   STEPSIZE            0.000001d0
c   SSWEIGHT            1.d-5
c
      do i=1,5
         do j=1,80
            cmctit(i)(j:j) = ' '
         enddo
      enddo
c
      mciufi      =   3
      mciufo      =   1
      mcityp      =   1
      mciord      =   0
      smmc        =   1.0d0
c
      dh          =   0.000001d0                                        0617OT08
      hh          =   1.d-6                                             0617OT08
      udelta      =   0.0000000256d0                                    0617OT08
      unn         =   2.d0                                               0617OT08
c
c                                                                       0305MH08 
c     EEMCMM            false                                           0305MH08 
c     UNITELPIN         volt                                            0305MH08 
c                                                                       0305MH08 
      mciee       =   0                                                 0305MH08 
      mciuph      =   1                                                 0305MH08 
c                                                                       0305MH08 
c     in MCGEN83                                                        0305MH08 
c     UNITELP           volt                                            0305MH08 
c     UNITDQDPHI        au                                              0305MH08 
c     UNITDQDR          bohr                                            0305MH08 
c     FORMQPHI          1                                               0305MH08 
c     FORMDQDPHI        gamess                                          0305MH08 
c     FORMDQDR          gamess                                          0305MH08 
c                                                                       0305MH08 
      mciups      =   2                                                 0305MH08 
      mciuvs      =   1                                                 0305MH08 
      mciurs      =   1                                                 0305MH08 
      mcifqs      =   1                                                 0305MH08 
      mcifqv      =   3                                                 0305MH08 
      mcifqr      =   3                                                 0305MH08 
c
c ----------------------------------------------------------------------
c     MCENERGETICS section
c ----------------------------------------------------------------------
c
c   ZERO1               vz1
c   ZERO2               vz2
c   EDIFF               ediff0
c
      vz1         =    0.d0
      vz2         =    0.d0
      ediff0      =    0.d0
c ----------------------------------------------------------------------
c     SYMMETRY section
c ----------------------------------------------------------------------
      ipermsym = 0                                                         1106OT06
      isigmav1 = 1                                                         1106OT06
      isigmav2 = 1                                                         1106OT06
      alphaV1 = 0.d0                                                       1106OT06
      alphaV2 = 0.d0                                                       1106OT06
c ----------------------------------------------------------------------
c     RESONANCE section
c ----------------------------------------------------------------------
c
c   RESMETHOD           shepard
c   POINTEXP            mcipex
c   RESFORM             mcifre
c   LINEARITY           nonlinear
c   RESVALUE            e12ct
c   PRINTIC             none
c   ICSHEPARD           no defaults
c   ICDISTANCE          no defaults
c
      mcimre      =    2
      mcipex      =    1
      mcifre      =    2
      mcilin      =    0
      mcipic      =    0
      e12ct       =    0.0318720274d0
      icomplex    =    1
      ijacob      =    0                                                1212OT08
      iwscale     =    0                                                1212OT08
c                                                                       0305MH08 
c   ISHMM               true                                            0305MH08 
c   IPRWGT              false                                           0305MH08 
c   EETYPE              charge                                          0305MH08 
c   IPRCOE              false                                           0305MH08 
c                                                                       0305MH08 
      mcshrp      =    0                                                0305MH08 
      mcprwg      =    0                                                0305MH08 
      mccdqv      =    0                                                0305MH08 
      mccdqr      =    0                                                0305MH08 
      mcpcoe      =    0                                                0601MH10
c
      mcipis      =    0                                                0601MH10
      mcipid      =    0                                                0601MH10
c
      return
      end
c***********************************************************************
c     mcsesi
c***********************************************************************
c
      subroutine mcsesi
c
c     This subroutine prepares the call for subroutines mcrfes and mctesi 
c     that read the electronic structure information and transform this
c     information to internal coordinates.
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'                                              0305MH08 
c
      logical redun
c
c     Initialize redun
c
      redun = .true.
c
c     Check for the number of internal coordinates if it exceeds the
c     maximum number allowed.
c
      if (mcnics.gt.mcmics) then
         write (fu6,100) mcnics, mcmics
         stop 'stop 1 in mcsesi'
      endif
c
c     Assign the number of vibrational degree of freedom which is different
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 (ipermsym.eq.0) then
      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,200) mcnics, mcnvdf
         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,200) mcnics, mcnvdf
         endif
      endif
      endif
c
c     Read and obtain the properties of the electronic structure theory
c     Shepard points from file esp.fu83.
c
      call mcrfes
      if (ipermsym.eq.0) then                                           1106OT06
c
         if(mciee.eq.0) then                                            0305MH08 
          if (mcihfr.eq.0) then
            call mctesi1st(redun)
c             call mctesi(redun)
          else
            call mctesi(redun)                                          0305MH08 
          endif
         else                                                           0305MH08 
            call eetesi(redun)                                          0305MH08 
         end if                                                         0305MH08 
c
      else                                                              1106OT06
          if (mcihfr.eq.0) then
            call mctesis1st(redun)
          else
            call mctesis(redun)                                             1106OT06
          endif
      endif                                                             1106OT06
c
 100  format (1x,'Wrong number of internal coordinates. ',
     *           'You have ',i5,' coordinates.',
     *       /1x,'Maximum number allowed is',i5,'. ',
     *           'Change mcparm.inc and recompile.')
 200  format (1x,'WARNING: ',i5,' internal coordinates are not ',
     *           'enough to properly span',
     *       /1x,'the vibrational space. Consider increasing the ',
     *           'number of internal coordinates to',i5,'.')
c
c
      return
      end
c ***************************************************************************
c     mcsici
c ***************************************************************************
c
      subroutine mcsici
c
c     This is a routine that do some checks on the read in internal 
c     coordinates and determine the internal coordinates that are both
c     used for Shepard interpolation and for generalized distances.
c     These internal coordinates will be teated differently because,
c     for these coordinates, the derivatives of the weights with respect
c     to the coordinates are needed.
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
c     Check if the internal coordinates read in have alowed values (smaller
c     than the number of atoms)
c
      if (mciord.eq.0.and.mcimre.ne.0) then
c
c     Internal coordinates for Shepard interpolation
c
         if (mcndis.gt.0) then
            do i = 1,2
               do j = 1, mcndis
                  if (mcidis(i,j).gt.mcnatm) then
                     write(fu6,1100)
                     write(fu6,1000)
                     stop 'mcsici 1'
                  endif
               enddo
            enddo
         endif
         if (mcnans.gt.0) then
            do i = 1,3
               do j = 1, mcnans
                  if (mcians(i,j).gt.mcnatm) then
                     write(fu6,1200)
                     write(fu6,1000)
                     stop 'mcsici 2'
                  endif
               enddo
            enddo
         endif
         if (mcnads.gt.0) then
            do i = 1,3
               do j = 1, mcnads
                  if (mciads(i,j).gt.mcnatm) then
                     write(fu6,1300)
                     write(fu6,1000)
                     stop 'mcsici 3'
                  endif
               enddo
            enddo
         endif
         if (mcndas.gt.0) then
            do i = 1,4
               do j = 1, mcndas
                  if (mcidas(i,j).gt.mcnatm) then
                     write(fu6,1400)
                     write(fu6,1000)
                     stop 'mcsici 4'
                  endif
               enddo
            enddo
         endif
c>>>>                                                                   0315MH10  
         if (mcsins.gt.0) then
            do j = 1, mcndas
               if (mcpnds(j).eq.0) then
                  write(fu6,1400)
                  write(fu6,1500)
                  stop 'mcsici 9'
               endif
            enddo
         endif
c<<<<                                                                   0315MH10  
c
c     Internal coordinates for generalized distances
c
         if (mcndid.gt.0) then
            do i = 1,2
               do j = 1, mcndid
                  if (mcidid(i,j).gt.mcnatm) then
                     write(fu6,1100)
                     write(fu6,1000)
                     stop 'mcsici 5'
                  endif
               enddo
            enddo
         endif
         if (mcnand.gt.0) then
            do i = 1,3
               do j = 1, mcnand
                  if (mciand(i,j).gt.mcnatm) then
                     write(fu6,1200)
                     write(fu6,1000)
                     stop 'mcsici 6'
                  endif
               enddo
            enddo
         endif
         if (mcnadd.gt.0) then
            do i = 1,3
               do j = 1, mcnadd
                  if (mciadd(i,j).gt.mcnatm) then
                     write(fu6,1300)
                     write(fu6,1000)
                     stop 'mcsici 7'
                  endif
               enddo
            enddo
         endif
         if (mcndad.gt.0) then
            do i = 1,4
               do j = 1, mcndad
                  if (mcidad(i,j).gt.mcnatm) then
                     write(fu6,1400)
                     write(fu6,1000)
                     stop 'mcsici 8'
                  endif
               enddo
            enddo
         endif
c>>>>                                                                   0315MH10  
         if (mcsind.gt.0) then
            do j = 1, mcndad
               if (mcpndd(j).eq.0) then
                  write(fu6,1400)
                  write(fu6,1500)
                  stop 'mcsici 10'
               endif
            enddo
         endif
c<<<<                                                                   0315MH10  
      endif
 1000 format (1x,'An atomic index exceds the number of atoms.')
 1100 format (1x,'Error in defining internuclear distances.')
 1200 format (1x,'Error in defining angles.')
 1300 format (1x,'Error in defining degenerate angles.')
 1400 format (1x,'Error in defining dihedral angles.')
 1500 format (1x,'All the periodicities of dihedral angles ',           0315MH10  
     &        'must be defined.')                                       0315MH10  
c
c     Determine the number and the index of the internal coordinates
c     used for both Shepard interpolation and generalized distances.
c
      mcnicb = 0
      if (mcndid.gt.0.and.mcndis.gt.0) then
         do i = 1, mcndid
            icode1=mcidid(1,i)*mcmatm+mcidid(2,i)
            do j = 1, mcndis
               icode2=mcidis(1,j)*mcmatm+mcidis(2,j)
               if (icode1.eq.icode2) then
                  mcnicb = mcnicb + 1
                  mciicb(mcnicb) = j
                  mciicb1(mcnicb) = i
               endif
            enddo
         enddo
      endif
      if (mcnand.gt.0.and.mcnans.gt.0) then
         do i = 1, mcnand
            icode1=(mciand(1,i)*mcmatm+mciand(2,i))*mcmatm
     *             +mciand(3,i)
            do j = 1, mcnans
               icode2=(mcians(1,j)*mcmatm+mcians(2,j))*mcmatm
     *                +mcians(3,j)
               if (icode1.eq.icode2) then
                  mcnicb = mcnicb + 1
                  mciicb(mcnicb) = j+mcndis
               endif
            enddo
         enddo
      endif
      if (mcndad.gt.0.and.mcndas.gt.0) then
         do i = 1, mcndad
            icode1=((mcidad(1,i)*mcmatm+mcidad(2,i))*mcmatm
     *              +mcidad(3,i))*mcmatm+mcidad(4,i)
            do j = 1, mcndas
               icode2=((mcidas(1,j)*mcmatm+mcidas(2,j))*mcmatm
     *                 +mcidas(3,j))*mcmatm+mcidas(4,j)
               if (icode1.eq.icode2) then
                  mcnicb = mcnicb + 1
                  mciicb(mcnicb) = j+mcndis+mcnans
               endif
            enddo
         enddo
      endif
      if (mcnadd.gt.0.and.mcnads.gt.0) then
         do i = 1, mcnadd
            icode1=(mciadd(1,i)*mcmatm+mciadd(2,i))*mcmatm
     *             +mciadd(3,i)
            do j = 1, mcnads
               icode2=(mciads(1,j)*mcmatm+mciads(2,j))*mcmatm
     *                +mciads(3,j)
               if (icode1.eq.icode2) then
                  mcnicb = mcnicb + 1
                  mciicb(mcnicb) = j+mcndis+mcnans+mcndas
                  mcnicb = mcnicb + 1
                  mciicb(mcnicb) = j+mcndis+mcnans+mcndas+mcnads
               endif
            enddo
         enddo
      endif
      return
      end
c ***************************************************************************
c     mcsrun
c ***************************************************************************
c
      subroutine mcsrun
c
c     This subroutine is the driver for the actual MCMM 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'                                              0305MH08 
c
      dimension x(mcmcar), dx(mcmcar), f(mcmcar,mcmcar)
c
      dimension phi(mcmatm)                                             0305MH08 
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
         x(i)=0.d0
         dx(i)=0.d0
         do j=1,mcmcar
            f(i,j)=0.d0
         enddo
      enddo
c
      do i=1,mcnatm                                                     0305MH08 
         phi(i)=0.0d+00                                                 0305MH08 
      end do                                                            0305MH08 
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'
c      finame = 'esp.fu84'
      call mcfset(fu84,finame)                                          0424MH08
c
      call mcfope (fu84, fistat, finame, lexit)
      if (lexit) then
         write (fu6,*) 'Error opening the fu84 input file'
         stop 'mcsrun 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 'mcsrun 1'
         endif
      else
         write (fu6,2000)
         stop 'mcsrun 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 'mcsrun 3'
         endif
      else
         write (fu6,4000)
         stop 'mcsrun 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 'mcsrun 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 'mcsrun 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 'mcsrun 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 'mcsrun 8'
               else
                  x(3*i-2) = cfmct(word(2))
                  x(3*i-1) = cfmct(word(3))
                  x(3*i) = cfmct(word(4))
c
                  if(nword.ge.5) phi(i) = cfmct(word(5))                0305MH08
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 'mcsrun 9'
               else
                  x(3*i-2) = cfmct(word(2))
                  x(3*i-1) = cfmct(word(3))
                  x(3*i) = cfmct(word(4))
c
                  if(nword.ge.5) phi(i) = cfmct(word(5))                0305MH08
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 'mcsrun 10'
               else
                  x(3*i-2) = cfmct(word(1))
                  x(3*i-1) = cfmct(word(2))
                  x(3*i) = cfmct(word(3))
c
                  if(nword.ge.4) phi(i) = cfmct(word(4))                0305MH08
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 'mcsrun 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 'mcsrun 8'
               else
                  x(3*i-2) = cfmct(word(3))
                  x(3*i-1) = cfmct(word(4))
                  x(3*i) = cfmct(word(5))
c
c                  if(nword.ge.5) phi(i) = cfmct(word(5))                0305MH08
c
               endif
            enddo
         endif
c
c     Transform the geometry to bohr
c
         do i=1,mcncar
            if (mciufi.eq.2) then
               x(i)=x(i)/cmmc(i)
            elseif (mciufi.eq.3) then
               x(i)=x(i)/fboan
            elseif (mciufi.eq.4) then
               x(i)=x(i)/(fboan*cmmc(i))
            endif
         enddo
c                                                                       0305MH08
c     Transform the potential to a.u.                                   0305MH08
c                                                                       0305MH08
         if(mciee.eq.1 .and. mciuph.eq.1) then                          0305MH08
            do i=1,mcnatm                                               0305MH08
               phi(i)=phi(i)/fhaev                                      0305MH08
            enddo                                                       0305MH08
         endif                                                          0305MH08
c
c     Determine what type of calculation and call the apropriate routine
c
         if (mciee.eq.0) then                                           0305MH08
c
            if (mcityp.eq.1) then
               if (ipermsym.eq.0) then                                  1106OT06
                  call mehook(x,v,e1,e2,e12,mcmcar,mciord,icomplex)
               else                                                     1106OT06
                  call mehooks(x,v,e1,e2,e12,mcmcar,mciord,alphaV1,     1106OT06
     *            alphaV2,isigmav1,isigmav2,icomplex)                   1106OT06
               endif                                                    1106OT06
            else if (mcityp.eq.2) then
               if (ipermsym.eq.0) then                                  1106OT06
                  call mghook(x,v,e1,e2,e12,dx,mcmcar,mciord,icomplex)
               else                                                     1106OT06
                  call mghooks(x,v,e1,e2,e12,dx,mcmcar,                 1106OT06
     *            mcncar,mciord,                                        1106OT06
     *            alphaV1,alphaV2,isigmav1,isigmav2,icomplex)           1106OT06
               endif                                                    1106OT06
            else
               if (ipermsym.eq.0) then                                  1106OT06
                call mhhook(x,v,e1,e2,e12,dx,f,mcmcar,mciord,icomplex)
               else                                                     1106OT06
                  call mhhooks(x,v,e1,e2,e12,dx,f,mcmcar,mcncar,        1106OT06
     *            mciord,                                               1106OT06
     *            alphaV1,alphaV2,isigmav1,isigmav2,icomplex)           1106OT06
               endif                                                    1106OT06
            endif
c
         else                                                           0305MH08
c
            if (mcityp.eq.1) then                                       0305MH08
               call eeehok(x,phi,v,e1,e2,e12)                           0305MH08
            else if (mcityp.eq.2) then                                  0305MH08
               call eeghok(x,phi,v,e1,e2,e12,dx)                        0305MH08
            else                                                        0305MH08
               call eehhok(x,phi,v,e1,e2,e12,dx,f)                      0305MH08
            endif                                                       0305MH08
c
         end if                                                         0305MH08
c
c     Print the geometry of the point and the MCMM results 
c
         call mcprez(mcipts,x,v,e1,e2,e12,dx,f)
c
         if(mciee.eq.1) call eeprez(phi,v)                              0305MH08
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
c ***************************************************************************
c     mcgradtest
c ***************************************************************************
c
      subroutine mcgradtest
c
c     This subroutine calculates analytical and numerical MCMM gradients
c     for comparison (added by O.T. in April 2008)
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)
      dimension dvdx(mcmcar),dvdy(mcmcar),dvdz(mcmcar)
      dimension dvdx1(mcmcar),dvdy1(mcmcar),dvdz1(mcmcar)
c
      dimension phi(mcmatm)                                             0225MH10
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
         dx(i)=0.d0
         dvdx(i)=0.d0
         dvdy(i)=0.d0
         dvdz(i)=0.d0
         dvdx(i)=0.d0
         dvdy(i)=0.d0
         dvdz(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 'mcsrun 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 'mcsrun 1'
         endif
      else
         write (fu6,2000)
         stop 'mcsrun 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 'mcsrun 3'
         endif
      else
         write (fu6,4000)
         stop 'mcsrun 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 'mcsrun 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 'mcsrun 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 'mcsrun 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 'mcsrun 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 'mcsrun 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 'mcsrun 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 'mcsrun 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 'mcsrun 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 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
         if (mciee.eq.0) then                                           0225MH10
c
       do i=0,mcnatm-1
C     x
        tmp=xt(i*3+1)
        xt(i*3+1)=tmp+dh
            if (ipermsym.eq.0) then
            call mghook(xt,v1,e1,e2,e12,dx,mcmcar,mciord,icomplex)
            else
             call mghooks(xt,v1,e1,e2,e12,dx,mcmcar,
     *       mcncar,mciord,
     *       alphaV1,alphaV2,isigmav1,isigmav2,icomplex)
            endif
        xt(i*3+1)=tmp-dh
            if (ipermsym.eq.0) then
            call mghook(xt,v2,e1,e2,e12,dx,mcmcar,mciord,icomplex)
            else
             call mghooks(xt,v2,e1,e2,e12,dx,mcmcar,
     *       mcncar,mciord,
     *       alphaV1,alphaV2,isigmav1,isigmav2,icomplex)
            endif
        dvdx1(i+1)=(v1-v2)/(2.d0*dh)
        xt(i*3+1)=tmp
C     y
        tmp=xt(i*3+2)
        xt(i*3+2)=tmp+dh
            if (ipermsym.eq.0) then
            call mghook(xt,v1,e1,e2,e12,dx,mcmcar,mciord,icomplex)
            else
             call mghooks(xt,v1,e1,e2,e12,dx,mcmcar,
     *       mcncar,mciord,
     *       alphaV1,alphaV2,isigmav1,isigmav2,icomplex)
            endif
        xt(i*3+2)=tmp-dh
            if (ipermsym.eq.0) then
            call mghook(xt,v2,e1,e2,e12,dx,mcmcar,mciord,icomplex)
            else
             call mghooks(xt,v2,e1,e2,e12,dx,mcmcar,
     *       mcncar,mciord,
     *       alphaV1,alphaV2,isigmav1,isigmav2,icomplex)
            endif
        dvdy1(i+1)=(v1-v2)/(2.d0*dh)
        xt(i*3+2)=tmp
C     z
        tmp=xt(i*3+3)
        xt(i*3+3)=tmp+dh
            if (ipermsym.eq.0) then
            call mghook(xt,v1,e1,e2,e12,dx,mcmcar,mciord,icomplex)
            else
             call mghooks(xt,v1,e1,e2,e12,dx,mcmcar,
     *       mcncar,mciord,
     *       alphaV1,alphaV2,isigmav1,isigmav2,icomplex)
            endif
        xt(i*3+3)=tmp-dh
            if (ipermsym.eq.0) then
            call mghook(xt,v2,e1,e2,e12,dx,mcmcar,mciord,icomplex)
            else
             call mghooks(xt,v2,e1,e2,e12,dx,mcmcar,
     *       mcncar,mciord,
     *       alphaV1,alphaV2,isigmav1,isigmav2,icomplex)
            endif
        dvdz1(i+1)=(v1-v2)/(2.d0*dh)
        xt(i*3+3)=tmp
       enddo
c
c get analytical gradient
c
            if (ipermsym.eq.0) then
            call mghook(xt,v,e1,e2,e12,dx,mcmcar,mciord,icomplex)
            else
             call mghooks(xt,v,e1,e2,e12,dx,mcmcar,
     *       mcncar,mciord,
     *       alphaV1,alphaV2,isigmav1,isigmav2,icomplex)
            endif
         do j = 1, mcnatm
             dvdx(j) = dx(3*j-2)
             dvdy(j) = dx(3*j-1)
             dvdz(j) = dx(3*j)
         end do
c
      else
c
c     EE-MCSI calculation
c
       do i=0,mcnatm-1
c
c     x
c
        tmp=xt(i*3+1)
        xt(i*3+1)=tmp+dh
        call eeghok(xt,phi,v1,e1,e2,e12,dx)
c
        xt(i*3+1)=tmp-dh
        call eeghok(xt,phi,v2,e1,e2,e12,dx)
c
        dvdx1(i+1)=(v1-v2)/(2.d0*dh)
        xt(i*3+1)=tmp
c
c     y
c
        tmp=xt(i*3+2)
        xt(i*3+2)=tmp+dh
        call eeghok(xt,phi,v1,e1,e2,e12,dx)
c
        xt(i*3+2)=tmp-dh
        call eeghok(xt,phi,v2,e1,e2,e12,dx)
c
        dvdy1(i+1)=(v1-v2)/(2.d0*dh)
        xt(i*3+2)=tmp
c
c     z
c
        tmp=xt(i*3+3)
        xt(i*3+3)=tmp+dh
c
        xt(i*3+3)=tmp+dh
        call eeghok(xt,phi,v1,e1,e2,e12,dx)
c
        xt(i*3+3)=tmp-dh
        call eeghok(xt,phi,v2,e1,e2,e12,dx)
c
        dvdz1(i+1)=(v1-v2)/(2.d0*dh)
        xt(i*3+3)=tmp
c
       enddo
c
c get analytical gradient
c
        call eeghok(xt,phi,v,e1,e2,e12,dx)
c
         do j = 1, mcnatm
             dvdx(j) = dx(3*j-2)
             dvdy(j) = dx(3*j-1)
             dvdz(j) = dx(3*j)
         end do
c
      end if
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) dvdx1(i),dvdy1(i),dvdz1(i),dvdx(i),dvdy(i),dvdz(i)
       enddo
 1001    format(/28X,'Numerical Gradient',41X,'Analytic Gradient')
 2002    format(1x,6f20.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     mchesstest
c ***************************************************************************
c
      subroutine mchesstest
c
c     This subroutine calculates analytical and numerical MCMM gradients
c     for comparison (added by O.T. in April 2008)
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), f(mcmcar,mcmcar)
      dimension hessnum(mcmcar,mcmcar),fdiff(mcmcar,mcmcar)
c
      dimension phi(mcmatm)                                             0225MH10
      dimension dxp(mcmcar),dxm(mcmcar)                                 0225MH10
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
      vpp=0.d0
      vpm=0.d0
      vmp=0.d0
      vmm=0.d0
      do i=1,mcmcar
         xt(i)=0.d0
         dx(i)=0.d0
         dxp(i)=0.0d+00                                                 0225MH10
         dxm(i)=0.0d+00                                                 0225MH10
        do j=1,mcmcar
         hessnum(i,j)=0.d0
         fdiff(i,j)=0.d0
        enddo
      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 'mcsrun 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 'mcsrun 1'
         endif
      else
         write (fu6,2000)
         stop 'mcsrun 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 'mcsrun 3'
         endif
      else
         write (fu6,4000)
         stop 'mcsrun 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 'mcsrun 5'
      endif
c
c     Check if the format of the input is allowed
c
      if (mcifrm.lt.1.or.mcifrm.gt.3) then
         write (fu6,6000)
         stop 'mcsrun 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 'mcsrun 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 'mcsrun 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 'mcsrun 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 'mcsrun 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
         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 hessian
c (the reason why we call mghook rather than mehook for numerical hessian is 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).
c
c
         if (mciee.eq.0) then                                           0225MH10
c
            if (ipermsym.eq.0) then
            call mghook(xt,v0,e1,e2,e12,dx,mcmcar,mciord,icomplex)
            else
             call mghooks(xt,v0,e1,e2,e12,dx,mcmcar,
     *       mcncar,mciord,
     *       alphaV1,alphaV2,isigmav1,isigmav2,icomplex)
            endif
c
c  Diagonal elements
c
       tmp=0.d0
       tmp2=0.d0
       do i=1,mcncar
C
        tmp=xt(i)
        xt(i)=tmp+dh
            if (ipermsym.eq.0) then
            call mghook(xt,v1,e1,e2,e12,dx,mcmcar,mciord,icomplex)
            else
             call mghooks(xt,v1,e1,e2,e12,dx,mcmcar,
     *       mcncar,mciord,
     *       alphaV1,alphaV2,isigmav1,isigmav2,icomplex)
            endif
        xt(i)=tmp-dh
            if (ipermsym.eq.0) then
            call mghook(xt,v2,e1,e2,e12,dx,mcmcar,mciord,icomplex)
            else
             call mghooks(xt,v2,e1,e2,e12,dx,mcmcar,
     *       mcncar,mciord,
     *       alphaV1,alphaV2,isigmav1,isigmav2,icomplex)
            endif
        hessnum(i,i)=(v1-2.d0*v0+v2)/(dh*dh)
        xt(i)=tmp
       enddo
c
c   Off-diagonal elements
c
       do i=1,mcncar
         do j=1,i
            if (j .ne. i) then
        tmp=xt(i)
        tmp2=xt(j)
        xt(i)=tmp+dh
        xt(j)=tmp2+dh
            if (ipermsym.eq.0) then
            call mghook(xt,vpp,e1,e2,e12,dx,mcmcar,mciord,icomplex)
            else
             call mghooks(xt,vpp,e1,e2,e12,dx,mcmcar,
     *       mcncar,mciord,
     *       alphaV1,alphaV2,isigmav1,isigmav2,icomplex)
            endif
        xt(i)=tmp+dh
        xt(j)=tmp2-dh
            if (ipermsym.eq.0) then
            call mghook(xt,vpm,e1,e2,e12,dx,mcmcar,mciord,icomplex)
            else
             call mghooks(xt,vpm,e1,e2,e12,dx,mcmcar,
     *       mcncar,mciord,
     *       alphaV1,alphaV2,isigmav1,isigmav2,icomplex)
            endif
        xt(i)=tmp-dh
        xt(j)=tmp2+dh
            if (ipermsym.eq.0) then
            call mghook(xt,vmp,e1,e2,e12,dx,mcmcar,mciord,icomplex)
            else
             call mghooks(xt,vmp,e1,e2,e12,dx,mcmcar,
     *       mcncar,mciord,
     *       alphaV1,alphaV2,isigmav1,isigmav2,icomplex)
            endif
        xt(i)=tmp-dh
        xt(j)=tmp2-dh
            if (ipermsym.eq.0) then
            call mghook(xt,vmm,e1,e2,e12,dx,mcmcar,mciord,icomplex)
            else
             call mghooks(xt,vmm,e1,e2,e12,dx,mcmcar,
     *       mcncar,mciord,
     *       alphaV1,alphaV2,isigmav1,isigmav2,icomplex)
            endif
        xt(i)=tmp
        xt(j)=tmp2
           hessnum(i,j)=(vpp-vpm-vmp+vmm)/(4.d0*dh*dh)
c           hessnum(j,i)=hessnum(i,j)
           endif
          enddo
        enddo
c
c get analytical hessian
c
            if (ipermsym.eq.0) then
            call mhhook(xt,v,e1,e2,e12,dx,f,mcmcar,mciord,icomplex)
            else
            call mhhooks(xt,v,e1,e2,e12,dx,f,mcmcar,mcncar,      
     *      mciord,                                             
     *      alphaV1,alphaV2,isigmav1,isigmav2,icomplex)                  
            endif
c
         else
c
c     EE-MCSI calculation
c
c$$$            call eeghok(xt,phi,v0,e1,e2,e12,dx)
c$$$c
c$$$c     Diagonal elements
c$$$c
c$$$            do i=1,mcncar
c$$$c
c$$$               tmp=xt(i)
c$$$               xt(i)=tmp+dh*10.0d+00
c$$$               call eeghok(xt,phi,v1,e1,e2,e12,dx)
c$$$c
c$$$               xt(i)=tmp-dh*10.0d+00
c$$$               call eeghok(xt,phi,v2,e1,e2,e12,dx)
c$$$c
c$$$               hessnum(i,i)=(v1-2.d0*v0+v2)/(dh*dh*100.0d+00)
c$$$               xt(i)=tmp
c$$$c
c$$$            enddo
c$$$c
c$$$c   Off-diagonal elements
c$$$c
c$$$            do i=1,mcncar
c$$$            do j=1,i
c$$$               if (j .ne. i) then
c$$$                  tmp=xt(i)
c$$$                  tmp2=xt(j)
c$$$c
c$$$                  xt(i)=tmp+dh
c$$$                  xt(j)=tmp2+dh
c$$$                  call eeghok(xt,phi,vpp,e1pp,e2pp,e12pp,dx)
c$$$c
c$$$                  xt(i)=tmp+dh
c$$$                  xt(j)=tmp2-dh
c$$$                  call eeghok(xt,phi,vpm,e1pm,e2pm,e12pm,dx)
c$$$c
c$$$                  xt(i)=tmp-dh
c$$$                  xt(j)=tmp2+dh
c$$$                  call eeghok(xt,phi,vmp,e1mp,e2mp,e12mp,dx)
c$$$c
c$$$                  xt(i)=tmp-dh
c$$$                  xt(j)=tmp2-dh
c$$$                  call eeghok(xt,phi,vmm,e1mm,e2mm,e12mm,dx)
c$$$c
c$$$                  xt(i)=tmp
c$$$                  xt(j)=tmp2
c$$$                  hessnum(i,j)=(vpp-vpm-vmp+vmm)/(4.d0*dh*dh)
c$$$c                  hessnum(j,i)=hessnum(i,j)
c$$$               endif
c$$$            enddo
c$$$            enddo
c$$$c
c
c     Hessian is cacluated by the first numerical derivatives of the gradient.
c
            do i=1,mcncar
c
               tmp=xt(i)
c
               xt(i)=tmp+dh
               call eeghok(xt,phi,vpp,e1pp,e2pp,e12pp,dxp)
c
               xt(i)=tmp-dh
               call eeghok(xt,phi,vmm,e1mm,e2mm,e12mm,dxm)
c
               xt(i)=tmp
c
               do j=1,mcncar
                  hessnum(i,j)=(dxp(j)-dxm(j))/(2.0d+00*dh)
               enddo
c
            enddo
c
            do i=1,mcncar
               do j=1,i-1
                  hesstmp=0.5d+00*(hessnum(i,j)+hessnum(j,i))
                  hessnum(i,j)=hesstmp
                  hessnum(j,i)=hesstmp
               enddo
            enddo
c
c get analytical hessian
c
            call eehhok(xt,phi,v,e1,e2,e12,dx,f)  
c
         endif
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,1003)
           do i=1,mcncar
               do j=1,i
                  fdiff(i,j)=hessnum(i,j)-f(i,j)
             write (6,2004) i,j, hessnum(i,j),f(i,j), fdiff(i,j)
               enddo
            enddo
 1003    format(/14X,'Numerical Hessian',4X,'Analytical Hessian',
     *          4X,'Difference')
 2004    format(1x,2i5,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     mcsvar
c ***************************************************************************
c
      subroutine mcsvar
c
c     This is a routine that set some variables expected by the MC-TINKER.
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
c     Scale atomic masses to reduced mass and define ammc array to hold
c     atomic mass factors. Redefine cmmc array to hold coordinate mass 
c     mass factors.
c                                                                       
      do i = 1, mcnatm                                           
         ammc(i) = sqrt(ammc(i)/smmc)                          
         cmmc(3*i-2) = ammc(i)
         cmmc(3*i-1) = ammc(i)
         cmmc(3*i) = ammc(i)
      enddo
c
c     Convert reduced mass with a factor that transform hartree to
c     amu*bohr**2/atu**2. This will be used in the transformation from 
c     Cartesian to internal coordinates.
c
      smmc = smmc/fhaam
c
      return
      end
c***********************************************************************
c     mcswtsnum1
c***********************************************************************
c
      subroutine mcswtsnum1(w,dwf,d2wf,itypec)
c
c     This subroutine calculates numerical gradients and Hessians
c     of the weight function. It is analogous to the mcswtsnum subroutine except
c     that it uses Jacobians ds/dr and Hessians d2s/dr2 ... (OT 01/08/09)
c
      implicit double precision (a-h, o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      dimension w(mcmesp*6+12),w1(mcmesp*6+12)
      dimension w2(mcmesp*6+12),wpp(mcmesp*6+12),wmp(mcmesp*6+12)
      dimension wpm(mcmesp*6+12),wmm(mcmesp*6+12)
      dimension  dwf(mcmesp*6+12,mcmicd)
      dimension  dwfds(mcmesp*6+12,mcmicd)
      dimension  d2wf(mcmics,mcmics,mcmesp*6+12)
      dimension  d2wf1(mcmics,mcmics,mcmesp*6+12)
      dimension  d2wf2(mcmics,mcmics,mcmesp*6+12)
      dimension  dsdr(mcmics,mcmicd)
      dimension d2sdrdr(mcmics,mcmics,mcmicd)
      dimension  d2wfds(mcmicd,mcmicd,mcmesp*6+12)
c
       do i=1,mcmesp*6+12
        w(i) =  0.d0
        w1(i) =  0.d0
        w2(i) =  0.d0
        wpp(i) =  0.d0
        wmp(i) =  0.d0
        wpm(i) =  0.d0
        wmm(i) =  0.d0
         do j=1,mcmics
          dwf(i,j)= 0.d0
           do ks=1,mcmicd
            dwfds(j,ks)= 0.d0
           enddo
         enddo
       enddo
        do i=1,mcmics
          do j=1,mcmicd
            dsdr(i,j)=0.d0
          enddo
       enddo
c
       do i=1,mcmics
       do j=1,mcmics
       do k=1,mcmesp*6+12
       d2wf(i,j,k)= 0.d0
       d2wf1(i,j,k)= 0.d0
       d2wf2(i,j,k)= 0.d0
       d2wfds(i,j,k)= 0.d0
       enddo
       enddo
       enddo
c
       if (ipermsym.eq.0) then
       mcnespn=mcnesp+2
       else if (ipermsym.eq.1) then
       mcnespn=mcnesp*6+12
       endif
c
c       write (*,*) "QD",qd(1),qd(2), qd(3)
c       qd(1)=qd(1)-0.00001
c       qs(2)=qs(2)-0.00001
c       write (*,*) "QD'",qd(1),qd(2), qd(3)
c
       tmp=0.d0
c       hh=1.d-5
cc        hh=1.d-7
c
       if (mcimre.eq.2) then
           if (ipermsym.eq.0) then
           call mcswts(w)
           else
           call mcswtss(w)
       endif
c
       do k=1,mcnespn
       if (w(k).eq.1.d0) then
       do i=1,mcnics
       dwf(k,i)=0.d0
       do j=1,mcnics
       d2wf(i,j,k)=0.d0
       enddo
       enddo
       goto 1001
       endif
       enddo
c       write (*,*) "angle", mcians(1,1), mcians(2,1),mcians(3,1)
c       write (*,*) "angle", mcians(1,2), mcians(2,2),mcians(3,2)
c       write (*,*) "dista", mcidid(1,mciicb1(1)), mcidid(2,mciicb1(1))
c       write (*,*) "dista", mcidid(1,mciicb1(2)), mcidid(2,mciicb1(2))
        do i=1,2
         kw=mcidid(i,mciicb1(1))
          do j=1,2
            kw1=mcidid(j,mciicb1(2))
             if (kw.eq.kw1) kangle=kw
          enddo
        enddo
c        write (*,*) "kang", kangle
        do i=1,mcnans
          if (mcians(2,i).eq.kangle) nangle=i
        enddo
c
c------------------ numeric evaluation of the first derivatives -----
c
c     first check if it is necessary (itypec >= 1)
c
          if (itypec .le. 1) goto 1001
c
       do i=1,mcnicd
c       kw=mciicb(i)
        tmp=qd(i)
        qd(i)=tmp+hh
           if (ipermsym.eq.0) then
           call mcswts(w1)
           else
           call mcswtss(w1)
           endif
        qd(i)=tmp-hh
           if (ipermsym.eq.0) then
           call mcswts(w2)
           else
           call mcswtss(w2)
           endif
       do mciesp=1,mcnespn
         dwfds(mciesp,i)=(w1(mciesp)-w2(mciesp))/(2.d0*hh)
c          write (*,*) "dwfds(mciesp,i)", 
c     &     dwfds(mciesp,i), mciesp,i
c         dwf(mciesp,kw)=(w1(mciesp)-w2(mciesp))/(2.d0*hh)
c         write (*,*) "dwf(mciesp,kw)=",dwf(mciesp,kw),mciesp,
c     *   kw,mcnespn
       enddo
        qd(i)=tmp
       enddo
           dsdr(mciicb(1),mciicb1(1))=1.d0
           dsdr(mciicb(2),mciicb1(2))=1.d0
c           write (*,*) "dsdr", dsdr(mciicb(1),mciicb1(1)),
c     *   dsdr(mciicb(2),mciicb1(2)), mciicb(1),mciicb1(1),
c     *   mciicb(2),mciicb1(2)
          do i=1,mcnicd
          if (i.ne.mciicb1(1).and.i.ne.mciicb1(2)) index=i
          enddo
c          write (*,*) "index", index
c
cc         dsdr(1,1)=0.d0
cc         dsdr(1,2)=0.d0
cc         dsdr(1,3)=0.d0
cc         dsdr(2,1)=1.d0
ccc         dsdr(2,2)=(qs(2)-qs(3)*dcos(qs(5)))/
ccc     *   dsqrt(qs(2)**2.d0+qs(3)**2.d0-
ccc     *   2.d0*qs(2)*qs(3)*dcos(qs(5)))
         dsdr(mciicb(1),index)=(qs(mciicb(1))-qs(mciicb(2))
     *   *dcos(qs(mcndis+nangle)))/
     *   dsqrt(qs(mciicb(1))**2.d0+qs(mciicb(2))**2.d0-
     *   2.d0*qs(mciicb(1))*qs(mciicb(2))*
     *   dcos(qs(mcndis+nangle)))
cc         dsdr(2,3)=0.d0
cc         dsdr(3,1)=0.d0
ccc         dsdr(3,2)=(qs(3)-qs(2)*dcos(qs(5)))/
ccc     *   dsqrt(qs(2)**2.d0+qs(3)**2.d0-
ccc     *   2.d0*qs(2)*qs(3)*dcos(qs(5)))
         dsdr(mciicb(2),index)=(qs(mciicb(2))-
     *   qs(mciicb(1))*dcos(qs(mcndis+nangle)))/
     *   dsqrt(qs(mciicb(1))**2.d0+qs(mciicb(2))**2.d0-
     *   2.d0*qs(mciicb(1))*qs(mciicb(2))*
     *   dcos(qs(mcndis+nangle)))
cc         dsdr(3,3)=1.d0
cc         dsdr(4,1)=0.d0
cc         dsdr(4,2)=0.d0
cc         dsdr(4,3)=0.d0
cc         dsdr(5,1)=0.d0
ccc         dsdr(5,2)=qs(2)*qs(3)*dsin(qs(5))/
ccc     *   dsqrt(qs(2)**2.d0+qs(3)**2.d0-
ccc     *   2.d0*qs(2)*qs(3)*dcos(qs(5)))
         dsdr(mcndis+nangle,index)=qs(mciicb(1))*qs(mciicb(2))*
     *   dsin(qs(mcndis+nangle))/
     *   dsqrt(qs(mciicb(1))**2.d0+
     *   qs(mciicb(2))**2.d0-
     *   2.d0*qs(mciicb(1))*qs(mciicb(2))*
     *   dcos(qs(mcndis+nangle)))
cc         dsdr(5,3)=0.d0
cc         dsdr(6,1)=0.d0
cc         dsdr(6,2)=0.d0
cc         dsdr(6,3)=0.d0
c         write (*,*) "coord",dsdr(2,2),dsdr(3,2),dsdr(5,2),
c     *   qs(5),dcos(qs(5)*57.2957795d0)
c         write (*,*) "coord1",qs(1),qs(2),qs(3),qs(4),qs(5),qs(6)
c         write (*,*) "coord2",qd(1),qd(2),qd(3),qd(4),qd(5),qd(6)
       do mciesp=1,mcnespn
        do kr=1,mcnics
         do ks=1,mcnicd
          dwf(mciesp,kr)=dwf(mciesp,kr)+
     &                  dwfds(mciesp,ks)*dsdr(kr,ks)
c          write (*,*) "dwf(mciesp,kr)",dwf(mciesp,kr),
c     &    dwfds(mciesp,ks),dsdr(kr,ks),mciesp,kr,ks
         enddo
c          write (*,*) "dwf",dwf(mciesp,kr),mciesp,kr
        enddo
       enddo
c           write (*,*) "dwf1",dwf(1,2),dwfds(1,1)
c           write (*,*) "dwf2",dwf(1,2),dwfds(1,1),dsdr(2,1)
c           write (*,*) "dwf3",dwf(1,1),dwf(1,2),dwf(1,3),
c     &     dwf(1,4),dwf(1,5),dwf(1,6)
c
c------------------ numeric evaluation of the second derivatives -----
c
c     first check if it is necessary (itypec = 3)
c
              if (itypec.eq. 2) goto 1001
c
       tmp=0.d0
       do i=1,mcmesp*6+12
        w1(i) =  0.d0
        w2(i) =  0.d0
       enddo
c
         do ids=1,mcmicd
           do idr=1,mcmics
              do idr1=1,mcmics
                d2sdrdr(idr,idr1,ids)=0.d0
              enddo
           enddo
         enddo
ccc         cat=dsqrt(qs(2)**2.d0+qs(3)**2.d0-
ccc     *   2.d0*qs(2)*qs(3)*dcos(qs(5)))
ccc         d2sdrdr(2,2,2)=1.d0/cat-0.5d0*(qs(2)-
ccc     *   qs(3)*dcos(qs(5)))**2.d0/cat**3.d0
         cat=dsqrt(qs(mciicb(1))**2.d0+qs(mciicb(2))**2.d0-
     *   2.d0*qs(mciicb(1))*qs(mciicb(2))*dcos(qs(mcndis+nangle)))
         d2sdrdr(mciicb(1),mciicb(1),index)=
     *   1.d0/cat-0.5d0*(qs(mciicb(1))-
     *   qs(mciicb(2))*dcos(qs(mcndis+nangle)))**2.d0/cat**3.d0
c
c         write (*,*) "coord1",qs(1),qs(2),qs(3),qs(4),qs(5),
c     *   qs(6),d2sdrdr(2,2,2)
ccc         d2sdrdr(3,3,2)=1.d0/cat-0.5d0*(qs(3)-
ccc     *   qs(2)*dcos(qs(5)))**2.d0/cat**3.d0
         d2sdrdr(mciicb(2),mciicb(2),index)=
     *   1.d0/cat-0.5d0*(qs(mciicb(2))-
     *   qs(mciicb(1))*dcos(qs(mcndis+nangle)))**2.d0/cat**3.d0
c
ccc         d2sdrdr(5,5,2)=qs(2)*qs(3)*dcos(qs(5))/cat-
ccc     *   (qs(2)*qs(3)*dsin(qs(5)))**2.d0/cat**3.d0
         d2sdrdr(mcndis+nangle,mcndis+nangle,index)=
     *   qs(mciicb(1))*qs(mciicb(2))*
     *   dcos(qs(mcndis+nangle))/cat-
     *   (qs(mciicb(1))*qs(mciicb(2))*
     *   dsin(qs(mcndis+nangle)))**2.d0/cat**3.d0
c
ccc         d2sdrdr(2,3,2)=-1.d0*dcos(qs(5))/cat-(2.d0*qs(2)-
ccc     *   2.d0*qs(3)*dcos(qs(5)))*
ccc     *   (2.d0*qs(3)-2.d0*qs(2)*dcos(qs(5)))/(4.d0*cat**3.d0)
         d2sdrdr(mciicb(1),mciicb(2),index)=
     *   -1.d0*dcos(qs(mcndis+nangle))/cat-
     *   (2.d0*qs(mciicb(1))-
     *   2.d0*qs(mciicb(2))*dcos(qs(mcndis+nangle)))*
     *   (2.d0*qs(mciicb(2))-2.d0*qs(mciicb(1))*
     *   dcos(qs(mcndis+nangle)))/(4.d0*cat**3.d0)
c
         d2sdrdr(mciicb(2),mciicb(1),index)=
     *   d2sdrdr(mciicb(1),mciicb(2),index)
c
ccc         d2sdrdr(2,5,2)=qs(3)*dsin(qs(5))/cat-
ccc     *   (qs(2)-qs(3)*dcos(qs(5)))*
ccc     *   qs(2)*qs(3)*dsin(qs(5))/cat**3.d0
         d2sdrdr(2,5,index)=qs(mciicb(2))*dsin(qs(mcndis+nangle))/cat-
     *   (qs(mciicb(1))-qs(mciicb(2))*dcos(qs(mcndis+nangle)))*
     *   qs(mciicb(1))*qs(mciicb(2))*dsin(qs(mcndis+nangle))/cat**3.d0
c
         d2sdrdr(mcndis+nangle,mciicb(1),index)=
     *   d2sdrdr(mciicb(1),mcndis+nangle,index)
c
ccc         d2sdrdr(3,5,2)=qs(2)*dsin(qs(5))/cat-
ccc     *   (qs(3)-qs(2)*dcos(qs(5)))*
ccc     *   qs(2)*qs(3)*dsin(qs(5))/cat**3.d0
         d2sdrdr(mciicb(2),mcndis+nangle,index)=
     *   qs(mciicb(1))*dsin(qs(mcndis+nangle))/cat-
     *   (qs(mciicb(2))-qs(mciicb(1))*dcos(qs(mcndis+nangle)))*
     *   qs(mciicb(1))*qs(mciicb(2))*dsin(qs(5))/cat**3.d0
c
         d2sdrdr(mcndis+nangle,mciicb(2),index)=
     *   d2sdrdr(mciicb(2),mcndis+nangle,index)
c
c  diagonal elements dw2/dqidqi
c
      do i=1,mcnicd
c       do i=1,mcnicb
c       kw=mciicb(i)
       tmp=qd(i)
       qd(i)=tmp+hh
           if (ipermsym.eq.0) then
           call mcswts(w1)
           else
           call mcswtss(w1)
           endif
       qd(i)=tmp-hh
           if (ipermsym.eq.0) then
           call mcswts(w2)
           else
           call mcswtss(w2)
           endif
       do mciesp=1,mcnespn
       d2wfds(i,i,mciesp)=(w1(mciesp)-2.d0*w(mciesp)+
     * w2(mciesp))/(hh*hh)
c       write (*,*) "d2wfds(i,i,mciesp)=", d2wfds(i,i,mciesp), i
       enddo
       qd(i)=tmp
       enddo
c
c
c  off-diagonal elements
c
       tmp=0.d0
       do i=1,mcnicd
cc       kw=mciicb(i)
ccc       do j=1,mcnicd
        do j=1,i
c       kw1=mciicb(j)
           if (j .ne. i) then
c
            tmp=qd(i)
            tmp2=qd(j)
            qd(i)=tmp+hh
            qd(j)=tmp2+hh
                if (ipermsym.eq.0) then
                call mcswts(wpp)
                else
                call mcswtss(wpp)
                endif
            qd(i)=tmp
            qd(j)=tmp2
c
            qd(i)=tmp+hh
            qd(j)=tmp2-hh
                if (ipermsym.eq.0) then
                call mcswts(wpm)
                else
                call mcswtss(wpm)
                endif
            qd(i)=tmp
            qd(j)=tmp2
c
            qd(i)=tmp-hh
            qd(j)=tmp2+hh
                if (ipermsym.eq.0) then
                call mcswts(wmp)
                else
                call mcswtss(wmp)
                endif
            qd(i)=tmp
            qd(j)=tmp2
c
            qd(i)=tmp-hh
            qd(j)=tmp2-hh
                if (ipermsym.eq.0) then
                call mcswts(wmm)
                else
                call mcswtss(wmm)
                endif
            qd(i)=tmp
            qd(j)=tmp2
c
           do mciesp=1,mcnespn
            d2wfds(i,j,mciesp)=(wpp(mciesp)-wpm(mciesp)-wmp(mciesp)+
     *      wmm(mciesp))/(4.d0*hh*hh)
            d2wfds(j,i,mciesp)=d2wfds(i,j,mciesp)
           enddo
c
           endif
          enddo
        enddo
c
       do mciesp=1,mcnespn
        do kr=1,mcnics
         do ks=1,mcnicd
           do ks1=1,mcnicd
             d2wf1(kr,kr,mciesp)=d2wf1(kr,kr,mciesp)+
     &          d2wfds(ks,ks1,mciesp)*dsdr(kr,ks)*
     &            dsdr(kr,ks1)
c           write (*,*) "count"
c         write (*,*) "sd", d2wfds(ks,ks1,mciesp),
c     &   dsdr(kr,ks),dsdr(kr,ks1),mciesp,kr,ks,ks1
           enddo
          d2wf2(kr,kr,mciesp)=d2wf2(kr,kr,mciesp)+
     &     dwfds(mciesp,ks)*d2sdrdr(kr,kr,ks)
c          write (*,*) "d2wf2",dwfds(mciesp,ks),d2sdrdr(kr,kr,ks),
c     &    d2wf2(kr,kr,mciesp),mciesp,kr,ks
         enddo
        enddo
       enddo
c
       do mciesp=1,mcnespn
        do kr=1,mcnics
         d2wf(kr,kr,mciesp)=d2wf1(kr,kr,mciesp)+d2wf2(kr,kr,mciesp)
c         write (*,*) "d2wf(kr,kr,mciesp)",d2wf1(kr,kr,mciesp),
c     &   d2wf2(kr,kr,mciesp),d2wf(kr,kr,mciesp), mciesp,kr,kr
        enddo
       enddo
c         d2wf(2,2,1)=d2wfds(1,1,1)
c         d2wf(2,2,2)=d2wfds(1,1,2)
c         d2wf(2,2,3)=d2wfds(1,1,3)
c         d2wf(3,3,1)=d2wfds(3,3,1)
c       do mciesp=1,mcnespn
c         d2wf(2,2,mciesp)=d2wfds(1,1,mciesp)
c         d2wf(3,3,mciesp)=d2wfds(3,3,mciesp)
c       enddo
c
       do mciesp=1,mcnespn
        do kr=1,mcnics
         do kr1=1,kr
            if (kr1 .ne. kr) then
           do ks=1,mcnicd
            do ks1=1,mcnicd
          d2wf1(kr,kr1,mciesp)=d2wf1(kr,kr1,mciesp)+
     &    d2wfds(ks,ks1,mciesp)*dsdr(kr,ks)*
     &    dsdr(kr1,ks1)
c           write (*,*) "OFF:",d2wfds(ks,ks1,mciesp),dsdr(kr1,ks1),
c     &      dsdr(kr,ks),mciesp,ks,ks1,kr,kr1
            enddo
c           d2wf2(kr,kr1,mciesp)=d2wf2(kr,kr1,mciesp)+
c     &          dwfds(mciesp,ks)*d2sdrdr(kr,kr1,ks)
c            write (*,*) "d2wf2-off",
c     &      dwfds(mciesp,ks),d2sdrdr(kr,kr1,ks),kr,kr1,ks
         enddo
         endif
        enddo
        enddo
       enddo

       do mciesp=1,mcnespn
        do kr=1,mcnics
         do kr1=1,kr
            if (kr1 .ne. kr) then
           do ks=1,mcnicd
           d2wf2(kr,kr1,mciesp)=d2wf2(kr,kr1,mciesp)+
     &          dwfds(mciesp,ks)*d2sdrdr(kr,kr1,ks)
          enddo
c            d2wf(kr1,kr,mciesp)=d2wf(kr,kr1,mciesp)
            endif
        enddo
        enddo
        enddo
c
       do mciesp=1,mcnespn
        do kr=1,mcnics
         do kr1=1,kr
            if (kr1 .ne. kr) then
           d2wf(kr,kr1,mciesp)=d2wf1(kr,kr1,mciesp)+
     &          d2wf2(kr,kr1,mciesp)
            d2wf(kr1,kr,mciesp)=d2wf(kr,kr1,mciesp)
c          write (*,*) "d2wf-off",d2wf2(kr,kr1,mciesp),mciesp,kr
            endif
         enddo
        enddo
       enddo
c
      elseif (mcimre.eq.1) then
         if (mcipex.le.mcnespn) then
            w(mcipex) = 1.d0
      do i=1,mcnicd
        dwf(mcipex,i)=0.d0
          do j=1,mcnicd
            d2wf(i,j,mcipex)=0.d0
        enddo
      enddo
c         else
c           write(fu6,2222)
c           stop 'mcswts 1'
         endif
      endif
c 2222 format (1x,'Error: The argument of POINTEXP should be ',
c     *           'smaller then the number of',/1x,'electronic ',
c     *           'structure points used in Shepard interpolation.')
c
1001    continue
c
      return
      end
c***********************************************************************
c     mcswtsnum
c***********************************************************************
c
      subroutine mcswtsnum(w,dwf,d2wf,itypec)
c
c     This subroutine calculates numerical gradients and Hessians
c     of the weight function. (OT 05/31/07)
c
      implicit double precision (a-h, o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      dimension w(mcmesp*6+12),w1(mcmesp*6+12)
      dimension w2(mcmesp*6+12),wpp(mcmesp*6+12),wmp(mcmesp*6+12)
      dimension wpm(mcmesp*6+12),wmm(mcmesp*6+12)
      dimension  dwf(mcmesp*6+12,mcmicd)
      dimension  d2wf(mcmicd,mcmicd,mcmesp*6+12)
c
       do i=1,mcmesp*6+12
        w(i) =  0.d0
        w1(i) =  0.d0
        w2(i) =  0.d0
        wpp(i) =  0.d0
        wmp(i) =  0.d0
        wpm(i) =  0.d0
        wmm(i) =  0.d0
         do j=1,mcmicd
          dwf(i,j)= 0.d0
         enddo
       enddo
c
       do i=1,mcmicd
       do j=1,mcmicd
       do k=1,mcmesp*6+12
       d2wf(i,j,k)= 0.d0
       enddo
       enddo
       enddo
c
       if (ipermsym.eq.0) then
       mcnespn=mcnesp+2
       else if (ipermsym.eq.1) then
       mcnespn=mcnesp*6+12
       endif
c
       tmp=0.d0
c       hh=1.d-5
cc        hh=1.d-7
c
       if (mcimre.eq.2) then
           if (ipermsym.eq.0) then
           call mcswts(w)
           else
           call mcswtss(w)
       endif
c
       do k=1,mcnespn
       if (w(k).eq.1.d0) then
       do i=1,mcnicd
       dwf(k,i)=0.d0
       do j=1,mcnicd
       d2wf(i,j,k)=0.d0
       enddo
       enddo
       goto 1001
       endif
       enddo
c
c------------------ numeric evaluation of the first derivatives -----
c
c     first check if it is necessary (itypec >= 1)
c
          if (itypec .le. 1) goto 1001
c
       do i=1,mcnicb
       kw=mciicb(i)
        tmp=qd(i)
        qd(i)=tmp+hh
           if (ipermsym.eq.0) then
           call mcswts(w1)
           else
           call mcswtss(w1)
           endif
        qd(i)=tmp-hh
           if (ipermsym.eq.0) then
           call mcswts(w2)
           else
           call mcswtss(w2)
           endif
       do mciesp=1,mcnespn
         dwf(mciesp,kw)=(w1(mciesp)-w2(mciesp))/(2.d0*hh)
c         write (*,*) "dwf(mciesp,kw)=",dwf(mciesp,kw),mciesp,
c     *   kw,mcnespn
       enddo
        qd(i)=tmp
       enddo
c
c------------------ numeric evaluation of the second derivatives -----
c
c     first check if it is necessary (itypec = 3)
c
              if (itypec.eq. 2) goto 1001
c
       tmp=0.d0
       do i=1,mcmesp*6+12
        w1(i) =  0.d0
        w2(i) =  0.d0
       enddo
c
c  diagonal elements dw2/dqidqi
c
c      do i=1,mcnicd
       do i=1,mcnicb
       kw=mciicb(i)
       tmp=qd(i)
       qd(i)=tmp+hh
           if (ipermsym.eq.0) then
           call mcswts(w1)
           else
           call mcswtss(w1)
           endif
       qd(i)=tmp-hh
           if (ipermsym.eq.0) then
           call mcswts(w2)
           else
           call mcswtss(w2)
           endif
       do mciesp=1,mcnespn
       d2wf(kw,kw,mciesp)=(w1(mciesp)-2.d0*w(mciesp)+
     * w2(mciesp))/(hh*hh)
       enddo
       qd(i)=tmp
       enddo
c
c  off-diagonal elements
c
       tmp=0.d0
       do i=1,mcnicb
       kw=mciicb(i)
       do j=1,mcnicb
c        do j=1,i
       kw1=mciicb(j)
           if (j .ne. i) then
c
            tmp=qd(i)
            tmp2=qd(j)
            qd(i)=tmp+hh
            qd(j)=tmp2+hh
                if (ipermsym.eq.0) then
                call mcswts(wpp)
                else
                call mcswtss(wpp)
                endif
            qd(i)=tmp
            qd(j)=tmp2
c
            qd(i)=tmp+hh
            qd(j)=tmp2-hh
                if (ipermsym.eq.0) then
                call mcswts(wpm)
                else
                call mcswtss(wpm)
                endif
            qd(i)=tmp
            qd(j)=tmp2
c
            qd(i)=tmp-hh
            qd(j)=tmp2+hh
                if (ipermsym.eq.0) then
                call mcswts(wmp)
                else
                call mcswtss(wmp)
                endif
            qd(i)=tmp
            qd(j)=tmp2
c
            qd(i)=tmp-hh
            qd(j)=tmp2-hh
                if (ipermsym.eq.0) then
                call mcswts(wmm)
                else
                call mcswtss(wmm)
                endif
            qd(i)=tmp
            qd(j)=tmp2
c
           do mciesp=1,mcnespn
            d2wf(kw,kw1,mciesp)=(wpp(mciesp)-wpm(mciesp)-wmp(mciesp)+
     *      wmm(mciesp))/(4.d0*hh*hh)
            d2wf(kw1,kw,mciesp)=d2wf(kw,kw1,mciesp)
           enddo
c
           endif
          enddo
        enddo
c
      elseif (mcimre.eq.1) then
         if (mcipex.le.mcnespn) then
            w(mcipex) = 1.d0
      do i=1,mcnicd
        dwf(mcipex,i)=0.d0
          do j=1,mcnicd
            d2wf(i,j,mcipex)=0.d0
        enddo
      enddo
c         else
c           write(fu6,2222)
c           stop 'mcswts 1'
         endif
      endif
c 2222 format (1x,'Error: The argument of POINTEXP should be ',
c     *           'smaller then the number of',/1x,'electronic ',
c     *           'structure points used in Shepard interpolation.')
c
1001    continue
c
      return
      end
c***********************************************************************
c     mcswts1
c***********************************************************************
c
      subroutine mcswts1(w)
c
c     This subroutine calculates the weights function 
c     (Titus V Albu January 2002). Modified by O.T.
c
      implicit double precision (a-h, o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      dimension dqs(mcmics,mcmesp+2),dqd(mcmicd,mcmesp+2)
c      dimension qdp(mcmicd), qdm(mcmicd)
      dimension w(mcmesp+2)
c     dimension dw(mcmesp+2)
c      dimension ddw1(mcmesp+2),ddw2(mcmesp+2)
c      dimension sdw(mcmics),sddw1(mcmics,mcmics)
c      dimension  dwf(mcmesp+2,mcmics)
c
      dimension distt(mcmesp+2),dism(mcmesp+2)
c      dimension wc(mcmesp+2),dwc(mcmesp+2),ddwc(mcmesp+2)
c      dimension wcc(mcmesp+2),ddk(mcmesp+2,mcmesp+2)
c     dimension disttp(mcmesp+2),disttm(mcmesp+2)
c
c
c     in case the SCMM reactant and product are not contained           0305MH08
c     in the Shepard points                                             0305MH08
c                                                                       0305MH08
      if(mcshrp.eq.1) goto 5000                                         0305MH08
c
               ceta = 4.0d0
c
c     zero out some variables
c
c      do i=1,mcmics
c        do j=1,mcmics
c          sddw1(i,j)= 0.d0
c        enddo
c          sdw(j)= 0.d0
c      enddo
      do i=1,mcmesp+2
        dism(i)  =  0.d0
        distt(i) =  0.d0
        w(i) =  0.d0
      enddo
      do j=1,mcnesp+2
         do i=1,mcnicd
            dqs(i,j)=0.d0
         enddo
      enddo
      do j=1,mcnesp+2
         do i=1,mcnicd
            dqs(i,j)=qs(i)-qs0(i,j)
         enddo
         if (mcndad.gt.0) then
            do i = mcndid+mcnand+1,mcndid+mcnand+mcndad
               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 
c     calculate the smallest distances between shepard points
c     added in a different form 4/29/99 by Y. Kim
c     I don't understand what's up with dism(i). It doesn't seem to be
c     used anywhere after it is calculated. TVA 24/01/02
c
      do i=1,mcnesp+2
         dist_sm=1.0d5
         do k=1,mcnesp+2
            if (k.ne.i) then
               dis0=0.d0
               do j=1,mcnicd
                  dis0=dis0+(qs0(j,k)-qs0(j,i))**2.d0
               enddo
               dist0 = dsqrt(dis0)
               if (dist0.lt.dist_sm) dist_sm = dist0
            endif
         enddo
         dism(i)=dist_sm
      enddo
c
c %%%% if selected, do calculations using Shepard interpolation %%%%%%%%%%%
c
c      if (mcimre.eq.2) then
c
c     calculate the distance between the current position and every 
c     Shepard point
c
         dist_m=1.d5
         do i=1,mcnesp+2
            diss=0.d0
            do j=1,mcnicd
               diss=diss+dqs(j,i)**2.d0
            enddo
            distt(i)=dsqrt(diss)
            if (distt(i).lt.dist_m) dist_m = distt(i)
         enddo
c 
c the reason we calculate dist_m and w(i) seperately is there may be
c more than one point with minimum distance
c
c calculate the unnormalized weight functions {w(i),i=1,mcnesp}
c and wsum
c
c when the point is very close to the interpolation point, it need to be
c treated specially to avoid divergence of the unnormalized weight function
c
        if (dist_m.le.1.d-8) then                                                 
c
c in case that the machine has strange round-off errors (?).
c
            do i=1,mcnesp+2
c               if (distt(i).le.(dist_m+1.d-37)) w(i)=1.d0
               if (distt(i).le.dist_m) w(i)=1.d0
            enddo
        else
c
c for different normalized weight function w(i), only the following block need
c to be changed.
c
c****************** begin evaluating weight functions *******************
c By Yongho Kim
c this part gives eq. 34 and 35 in Kim et all J. Chem. Phys. 112 (2000) 2718
c
            do i=1,mcnesp+2
               dstnce = distt(i)
               if (dstnce.eq.0.0d0) then
                   w(i) = 1.00d0
               else
                   w(i) = 0.0d0
                   wca = 0.0d0
               endif
            enddo
c
            if (icomplex.eq.1) then
            call mcwscale
            else
            call mcwscale1
            endif
c
c denominator of eq 34 of Kim et al:
c (note that there is a typo in this eq.: both i and k should be k'})
                   do j=1,mcnesp
                      wca = wca + Fw(j)/distt(j)**ceta
                   enddo
                   do j=mcnesp+1,mcnesp+2
                      wca = wca + 1.d0/distt(j)**ceta
                   enddo
c
            do 111  i=1,mcnesp
               dstnce = distt(i)
                   w(i) = Fw(i)/(dstnce**ceta*wca)
c                write (*,*) " w(i) =",  distt(i), w(i)
 111     continue
            do 112 i=mcnesp+1,mcnesp+2
               dstnce = distt(i)
                   w(i) = 1.d0/(dstnce**ceta*wca)
c                   write (*,*) " w(i)mm =",  distt(i), w(i)
 112     continue
         endif
c this part is moved to the mswtsnum subroutine.
c %%%% if (mcimre = 1), only one point is considered with a weight of 1 %%%%%
c
c      elseif (mcimre.eq.1) then
c         if (mcipex.le.mcnesp) then
c            w(mcipex) = 1.d0
c         else 
c           write(fu6,2222)
c           stop 'mcswts 1'
c         endif
c      endif
c 2222 format (1x,'Error: The argument of POINTEXP should be ',
c     *           'smaller then the number of',/1x,'electronic ',
c     *           'structure points used in Shepard interpolation.')
c
c
       return
c
 5000  continue
c
c     in case the SCMM reactant and product are not contained           0305MH08
c     in the Shepard points                                             0305MH08
c
       ceta = 4.0d0
c
c     zero out some variables
c
c      do i=1,mcmics
c        do j=1,mcmics
c          sddw1(i,j)= 0.d0
c        enddo
c          sdw(j)= 0.d0
c      enddo
      do i=1,mcmesp
        dism(i)  =  0.d0
        distt(i) =  0.d0
        w(i) =  0.d0
c        wc(i) =  0.d0
c        dw(i) =  0.d0
c        ddw1(i) =  0.d0
c        ddw2(i) =  0.d0
c        dwc(i) = 0.d0
c         do j=1,mcmics
c          dwf(i,j)= 0.d0
c         enddo
      enddo
      do j=1,mcnesp
         do i=1,mcnicd
            dqd(i,j)=0.d0
         enddo
      enddo
      do j=1,mcnesp
         do i=1,mcnicd
            dqd(i,j)=qd(i)-qd0(i,j)
         enddo
         if (mcndad.gt.0) then
            do i = mcndid+mcnand+1,mcndid+mcnand+mcndad
               if (dqd(i,j).lt.-fpi) then
                   dqd(i,j) = dqd(i,j)+2.0d0*fpi
               elseif (dqd(i,j).gt.fpi) then
                   dqd(i,j) = dqd(i,j)-2.0d0*fpi
               endif
            enddo
         endif
      enddo
c 
c     calculate the smallest distances between shepard points
c     added in a different form 4/29/99 by Y. Kim
c     I don't understand what's up with dism(i). It doesn't seem to be
c     used anywhere after it is calculated. TVA 24/01/02
c
      do i=1,mcnesp
         dist_sm=1.0d5
         do k=1,mcnesp
            if (k.ne.i) then
               dis0=0.d0
               do j=1,mcnicd
                  dis0=dis0+(qd0(j,k)-qd0(j,i))**2.d0
               enddo
               dist0 = dsqrt(dis0)
               if (dist0.lt.dist_sm) dist_sm = dist0
            endif
         enddo
         dism(i)=dist_sm
      enddo
c
c %%%% if selected, do calculations using Shepard interpolation %%%%%%%%%%%
c
c      if (mcimre.eq.2) then
c
c     calculate the distance between the current position and every 
c     Shepard point
c
         dist_m=1.d5
         do i=1,mcnesp
            diss=0.d0
            do j=1,mcnicd
               diss=diss+dqd(j,i)**2.d0
            enddo
            distt(i)=dsqrt(diss)
            if (distt(i).lt.dist_m) dist_m = distt(i)
         enddo
c 
c the reason we calculate dist_m and w(i) seperately is there may be
c more than one point with minimum distance
c
c calculate the unnormalized weight functions {w(i),i=1,mcnesp}
c and wsum
c
c when the point is very close to the interpolation point, it need to be
c treated specially to avoid divergence of the unnormalized weight function
c
        if (dist_m.le.1.d-8) then                                                 
c
c in case that the machine has strange round-off errors (?).
c
            do i=1,mcnesp
c               if (distt(i).le.(dist_m+1.d-37)) w(i)=1.d0
               if (distt(i).le.dist_m) w(i)=1.d0
            enddo
        else
c
c for different normalized weight function w(i), only the following block need
c to be changed.
c
c****************** begin evaluating weight functions *******************
c By Yongho Kim
c this part gives eq. 34 and 35 in Kim et all J. Chem. Phys. 112 (2000) 2718
c
            do i=1,mcnesp
               dstnce = distt(i)
               if (dstnce.eq.0.0d0) then
                   w(i) = 1.00d0
               else
                   w(i) = 0.0d0
                   wca = 0.0d0
               endif
            enddo
c
c denominator of eq 34 of Kim et al:
c (note that there is a typo in this eq.: both i and k should be k'})
                   do j=1,mcnesp
                      wca = wca + 1.d0/distt(j)**ceta
                   enddo
c
            do 5111  i=1,mcnesp
               dstnce = distt(i)
                   w(i) = 1.d0/(dstnce**ceta*wca)
c
c next is equation 40 in Kim et all J. Chem. Phys. 112 (2000) 2718
c
c                   dwc(i) = ceta*wc(i)*(wc(i)-1.0d0)/dstnce
c
c next is equation 41 in Kim et all J. Chem. Phys. 112 (2000) 2718
c
c                   ddwc(i) = wc(i)*(2.0d0*ceta*ceta*wc(i)*wc(i)
c     *                       -(ceta+3.0d0*ceta*ceta)*wc(i)
c     *                       +(1.0d0+ceta)*ceta)/dstnce**2.0d0
c
c               w(i) = wc(i)
c
c               dw(i) = dwc(i)/dstnce
c
c               ddw1(i) = ddwc(i)
c
c               ddw1(i) = (ddw1(i)-dw(i))/dstnce**2.d0
c
c               ddw2(i) = dw(i)
c
c******************* end of evaluation of weight functions ********************
c
c               wsum  = wsum + w(i)
c               do j=1,mcnicb
c                  jw = mciicb(j)
c                  detqj=dqs(jw,i)
c                  sdw(j)= sdw(j) + dw(i)*detqj
c                  dwf(i,j)=dwc(i)/dstnce*dqd(j,i)
c                  do k=j,mcnicb
c                     kw = mciicb(k)
c                     sddw1(j,k) = sddw1(j,k)+ddw1(i)*detqj*dqs(kw,i)
c                     sddw1(k,j) = sddw1(j,k)
c                  enddo
c               enddo
c               sddw2 = sddw2 + ddw2(i)
c
c end of loop over the number shepard points
c
 5111     continue
         endif
c this part is moved to the mswtsnum subroutine.
c %%%% if (mcimre = 1), only one point is considered with a weight of 1 %%%%%
c
c      elseif (mcimre.eq.1) then
c         if (mcipex.le.mcnesp) then
c            w(mcipex) = 1.d0
c         else 
c           write(fu6,2222)
c           stop 'mcswts 1'
c         endif
c      endif
c 2222 format (1x,'Error: The argument of POINTEXP should be ',
c     *           'smaller then the number of',/1x,'electronic ',
c     *           'structure points used in Shepard interpolation.')
c
c
      return
      end
c***********************************************************************
c     mcswts
c***********************************************************************
c
      subroutine mcswts(w)
c
c     This subroutine calculates the weights function 
c     (Titus V Albu January 2002). Modified by O.T.
c
      implicit double precision (a-h, o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      dimension dqs(mcmics,mcmesp+2),dqd(mcmicd,mcmesp+2)
c      dimension qdp(mcmicd), qdm(mcmicd)
      dimension w(mcmesp+2)
c     dimension dw(mcmesp+2)
c      dimension ddw1(mcmesp+2),ddw2(mcmesp+2)
c      dimension sdw(mcmics),sddw1(mcmics,mcmics)
c      dimension  dwf(mcmesp+2,mcmics)
c
      dimension distt(mcmesp+2),dism(mcmesp+2)
c      dimension wc(mcmesp+2),dwc(mcmesp+2),ddwc(mcmesp+2)
c      dimension wcc(mcmesp+2),ddk(mcmesp+2,mcmesp+2)
c     dimension disttp(mcmesp+2),disttm(mcmesp+2)
c
c
c     in case the SCMM reactant and product are not contained           0305MH08
c     in the Shepard points                                             0305MH08
c                                                                       0305MH08
      if(mcshrp.eq.1) goto 5000                                         0305MH08
c
               ceta = 4.0d0
c
c     zero out some variables
c
c      do i=1,mcmics
c        do j=1,mcmics
c          sddw1(i,j)= 0.d0
c        enddo
c          sdw(j)= 0.d0
c      enddo
      do i=1,mcmesp+2
        dism(i)  =  0.d0
        distt(i) =  0.d0
        w(i) =  0.d0
      enddo
      do j=1,mcmesp+2
         do i=1,mcmicd
            dqd(i,j)=0.d0
         enddo
      enddo
      do j=1,mcnesp+2
         do i=1,mcnicd
            dqd(i,j)=qd(i)-qd0(i,j)
         enddo
         if (mcndad.gt.0) then
            do i = mcndid+mcnand+1,mcndid+mcnand+mcndad
               if (dqd(i,j).lt.-fpi) then
                   dqd(i,j) = dqd(i,j)+2.0d0*fpi
               elseif (dqd(i,j).gt.fpi) then
                   dqd(i,j) = dqd(i,j)-2.0d0*fpi
               endif
            enddo
         endif
      enddo
c>>>>                                                                   0601MH10
      if(mcsind.ne.0) then
         do j=1,mcnesp+2
            do i = mcndid+mcnand+1,mcndid+mcnand+mcndad
               pn=dble(mcpndd(i-mcndid-mcnand))
               dqd(i,j)=sin(pn*dqd(i,j))/pn
            enddo
         enddo
      endif
c<<<<                                                                   0601MH10
c 
c     calculate the smallest distances between shepard points
c     added in a different form 4/29/99 by Y. Kim
c     I don't understand what's up with dism(i). It doesn't seem to be
c     used anywhere after it is calculated. TVA 24/01/02
c
      do i=1,mcnesp+2
         dist_sm=1.0d5
         do k=1,mcnesp+2
            if (k.ne.i) then
               dis0=0.d0
               do j=1,mcnicd
                  dis0=dis0+(qd0(j,k)-qd0(j,i))**2.d0
               enddo
               dist0 = dsqrt(dis0)
               if (dist0.lt.dist_sm) dist_sm = dist0
            endif
         enddo
         dism(i)=dist_sm
      enddo
c
c %%%% if selected, do calculations using Shepard interpolation %%%%%%%%%%%
c
c      if (mcimre.eq.2) then
c
c     calculate the distance between the current position and every 
c     Shepard point
c
         dist_m=1.d5
         do i=1,mcnesp+2
            diss=0.d0
            do j=1,mcnicd
               diss=diss+dqd(j,i)**2.d0
            enddo
            distt(i)=dsqrt(diss)
            if (distt(i).lt.dist_m) dist_m = distt(i)
         enddo
c 
c the reason we calculate dist_m and w(i) seperately is there may be
c more than one point with minimum distance
c
c calculate the unnormalized weight functions {w(i),i=1,mcnesp}
c and wsum
c
c when the point is very close to the interpolation point, it need to be
c treated specially to avoid divergence of the unnormalized weight function
c
        if (dist_m.le.1.d-8) then                                                 
c
c in case that the machine has strange round-off errors (?).
c
            do i=1,mcnesp+2
c               if (distt(i).le.(dist_m+1.d-37)) w(i)=1.d0
               if (distt(i).le.dist_m) w(i)=1.d0
            enddo
        else
c
c for different normalized weight function w(i), only the following block need
c to be changed.
c
c****************** begin evaluating weight functions *******************
c By Yongho Kim
c this part gives eq. 34 and 35 in Kim et all J. Chem. Phys. 112 (2000) 2718
c
            do i=1,mcnesp+2
               dstnce = distt(i)
               if (dstnce.eq.0.0d0) then
                   w(i) = 1.00d0
               else
                   w(i) = 0.0d0
                   wca = 0.0d0
               endif
            enddo
c
            if (iwscale.eq.0) then                                      0108OT09
                   do j=1,mcnesp                                        0108OT09
                      Fw(j)=1.0d0                                       0108OT09
                   enddo                                                0108OT09
            else                                                        0108OT09
                   if (icomplex.eq.1) then                              0108OT09
                     call mcwscale                                      0108OT09
                   else                                                 0108OT09
                     call mcwscale1                                     0108OT09
                   endif                                                0108OT09
            endif                                                       0108OT09
c
c denominator of eq 34 of Kim et al:
c (note that there is a typo in this eq.: both i and k should be k'})
c (note that if scaling of the weights is used, weight function is
c calculated as defined by eq 29 of JCP, 129, 1 (Tishchenko & Truhlar))
c
                   do j=1,mcnesp
                      wca = wca + Fw(j)/distt(j)**ceta                  0108OT09
                   enddo
                   do j=mcnesp+1,mcnesp+2                               0108OT09
                      wca = wca + 1.d0/distt(j)**ceta                   0108OT09
                   enddo                                                0108OT09
c
            do 111  i=1,mcnesp
               dstnce = distt(i)
                   w(i) = Fw(i)/(dstnce**ceta*wca)                      0108OT09
 111     continue
            do 112 i=mcnesp+1,mcnesp+2                                  0108OT09
               dstnce = distt(i)                                        0108OT09
                   w(i) = 1.d0/(dstnce**ceta*wca)                       0108OT09
 112     continue                                                       0108OT09
         endif
c this part is moved to the mswtsnum subroutine.
c %%%% if (mcimre = 1), only one point is considered with a weight of 1 %%%%%
c
c      elseif (mcimre.eq.1) then
c         if (mcipex.le.mcnesp) then
c            w(mcipex) = 1.d0
c         else 
c           write(fu6,2222)
c           stop 'mcswts 1'
c         endif
c      endif
c 2222 format (1x,'Error: The argument of POINTEXP should be ',
c     *           'smaller then the number of',/1x,'electronic ',
c     *           'structure points used in Shepard interpolation.')
c
c
       return
c
 5000  continue
c
c     in case the SCMM reactant and product are not contained           0305MH08
c     in the Shepard points                                             0305MH08
c
       ceta = 4.0d0
c
c     zero out some variables
c
c      do i=1,mcmics
c        do j=1,mcmics
c          sddw1(i,j)= 0.d0
c        enddo
c          sdw(j)= 0.d0
c      enddo
      do i=1,mcmesp
        dism(i)  =  0.d0
        distt(i) =  0.d0
        w(i) =  0.d0
c        wc(i) =  0.d0
c        dw(i) =  0.d0
c        ddw1(i) =  0.d0
c        ddw2(i) =  0.d0
c        dwc(i) = 0.d0
c         do j=1,mcmics
c          dwf(i,j)= 0.d0
c         enddo
      enddo
      do j=1,mcnesp
         do i=1,mcnicd
            dqd(i,j)=0.d0
         enddo
      enddo
      do j=1,mcnesp
         do i=1,mcnicd
            dqd(i,j)=qd(i)-qd0(i,j)
         enddo
         if (mcndad.gt.0) then
            do i = mcndid+mcnand+1,mcndid+mcnand+mcndad
               if (dqd(i,j).lt.-fpi) then
                   dqd(i,j) = dqd(i,j)+2.0d0*fpi
               elseif (dqd(i,j).gt.fpi) then
                   dqd(i,j) = dqd(i,j)-2.0d0*fpi
               endif
            enddo
         endif
      enddo
c>>>>                                                                   0601MH10
      if(mcsind.ne.0) then
         do j=1,mcnesp
            do i = mcndid+mcnand+1,mcndid+mcnand+mcndad
               pn=dble(mcpndd(i-mcndid-mcnand))
               dqd(i,j)=sin(pn*dqd(i,j))/pn
            enddo
         enddo
      endif
c<<<<                                                                   0601MH10
c 
c     calculate the smallest distances between shepard points
c     added in a different form 4/29/99 by Y. Kim
c     I don't understand what's up with dism(i). It doesn't seem to be
c     used anywhere after it is calculated. TVA 24/01/02
c
      do i=1,mcnesp
         dist_sm=1.0d5
         do k=1,mcnesp
            if (k.ne.i) then
               dis0=0.d0
               do j=1,mcnicd
                  dis0=dis0+(qd0(j,k)-qd0(j,i))**2.d0
               enddo
               dist0 = dsqrt(dis0)
               if (dist0.lt.dist_sm) dist_sm = dist0
            endif
         enddo
         dism(i)=dist_sm
      enddo
c
c %%%% if selected, do calculations using Shepard interpolation %%%%%%%%%%%
c
c      if (mcimre.eq.2) then
c
c     calculate the distance between the current position and every 
c     Shepard point
c
         dist_m=1.d5
         do i=1,mcnesp
            diss=0.d0
            do j=1,mcnicd
               diss=diss+dqd(j,i)**2.d0
            enddo
            distt(i)=dsqrt(diss)
            if (distt(i).lt.dist_m) dist_m = distt(i)
         enddo
c 
c the reason we calculate dist_m and w(i) seperately is there may be
c more than one point with minimum distance
c
c calculate the unnormalized weight functions {w(i),i=1,mcnesp}
c and wsum
c
c when the point is very close to the interpolation point, it need to be
c treated specially to avoid divergence of the unnormalized weight function
c
        if (dist_m.le.1.d-8) then                                                 
c
c in case that the machine has strange round-off errors (?).
c
            do i=1,mcnesp
c               if (distt(i).le.(dist_m+1.d-37)) w(i)=1.d0
               if (distt(i).le.dist_m) w(i)=1.d0
            enddo
        else
c
c for different normalized weight function w(i), only the following block need
c to be changed.
c
c****************** begin evaluating weight functions *******************
c By Yongho Kim
c this part gives eq. 34 and 35 in Kim et all J. Chem. Phys. 112 (2000) 2718
c
            do i=1,mcnesp
               dstnce = distt(i)
               if (dstnce.eq.0.0d0) then
                   w(i) = 1.00d0
               else
                   w(i) = 0.0d0
                   wca = 0.0d0
               endif
            enddo
c
c denominator of eq 34 of Kim et al:
c (note that there is a typo in this eq.: both i and k should be k'})
                   do j=1,mcnesp
                      wca = wca + 1.d0/distt(j)**ceta
                   enddo
c
            do 5111  i=1,mcnesp
               dstnce = distt(i)
                   w(i) = 1.d0/(dstnce**ceta*wca)
c
c next is equation 40 in Kim et all J. Chem. Phys. 112 (2000) 2718
c
c                   dwc(i) = ceta*wc(i)*(wc(i)-1.0d0)/dstnce
c
c next is equation 41 in Kim et all J. Chem. Phys. 112 (2000) 2718
c
c                   ddwc(i) = wc(i)*(2.0d0*ceta*ceta*wc(i)*wc(i)
c     *                       -(ceta+3.0d0*ceta*ceta)*wc(i)
c     *                       +(1.0d0+ceta)*ceta)/dstnce**2.0d0
c
c               w(i) = wc(i)
c
c               dw(i) = dwc(i)/dstnce
c
c               ddw1(i) = ddwc(i)
c
c               ddw1(i) = (ddw1(i)-dw(i))/dstnce**2.d0
c
c               ddw2(i) = dw(i)
c
c******************* end of evaluation of weight functions ********************
c
c               wsum  = wsum + w(i)
c               do j=1,mcnicb
c                  jw = mciicb(j)
c                  detqj=dqs(jw,i)
c                  sdw(j)= sdw(j) + dw(i)*detqj
c                  dwf(i,j)=dwc(i)/dstnce*dqd(j,i)
c                  do k=j,mcnicb
c                     kw = mciicb(k)
c                     sddw1(j,k) = sddw1(j,k)+ddw1(i)*detqj*dqs(kw,i)
c                     sddw1(k,j) = sddw1(j,k)
c                  enddo
c               enddo
c               sddw2 = sddw2 + ddw2(i)
c
c end of loop over the number shepard points
c
 5111     continue
         endif
c this part is moved to the mswtsnum subroutine.
c %%%% if (mcimre = 1), only one point is considered with a weight of 1 %%%%%
c
c      elseif (mcimre.eq.1) then
c         if (mcipex.le.mcnesp) then
c            w(mcipex) = 1.d0
c         else 
c           write(fu6,2222)
c           stop 'mcswts 1'
c         endif
c      endif
c 2222 format (1x,'Error: The argument of POINTEXP should be ',
c     *           'smaller then the number of',/1x,'electronic ',
c     *           'structure points used in Shepard interpolation.')
c
c
      return
      end
c***********************************************************************
c     mcswtss
c***********************************************************************
c
      subroutine mcswtss(w)
c
c     This subroutine is similar to mcswts but is used in symmetrized
c     calculations. (O.T.)
c
      implicit double precision (a-h, o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
c
      dimension w(mcmesp*6+12),wes(mcmesp*6)
      dimension wmm1(6),wmm2(6),wmm(12)
      dimension distt(mcmesp*6+12),dism(mcmesp*6+12)                    
c      dimension distt_mm1(6),distt_mm2(6)
      dimension distt_mm(2,6) 
      dimension indexmm(2,6)
      dimension indexmm1(6),indexmm2(6)
      dimension disttmm(12),indexes(mcmesp,12)
      dimension distt_es(mcmesp*6,6),disttes(mcmesp*6)
c
      ceta = 4.0d0
c
c     zero out some variables
c
      do i=1,mcmesp*6+12                                                
        dism(i)  =  0.d0
        distt(i) =  0.d0
        w(i) =  0.d0
      enddo
       do i=1,mcmesp*6
       wes(i)=0.d0
c        wprint(i) =  0.d0
       enddo
       do i=1,6
       wmm1(i)=0.d0
       wmm2(i)=0.d0
       enddo
c
      do j=1,mcmesp*6+12
         do i=1,mcmicd
            dqd_p12(i,j)=0.d0
         enddo
      enddo
      do j=1,mcnesp*6+12                                                
         do i=1,mcnicd                                                  
            dqd_p12(i,j)=qd(i)-qd0_p12(i,j)                             
         enddo                                                          
         if (mcndad.gt.0) then                                          
            do i = mcndid+mcnand+1,mcndid+mcnand+mcndad                 
               if (dqd_p12(i,j).lt.-fpi) then                           
                   dqd_p12(i,j) = dqd_p12(i,j)+2.0d0*fpi                
               elseif (dqd_p12(i,j).gt.fpi) then                        
                   dqd_p12(i,j) = dqd_p12(i,j)-2.0d0*fpi                
               endif                                                    
            enddo                                                       
         endif                                                          
      enddo                                                             
c
c 
c     calculate the smallest distances between shepard points
c     added in a different form 4/29/99 by Y. Kim
c     I don't understand what's up with dism(i). It doesn't seem to be
c     used anywhere after it is calculated. TVA 24/01/02
c
c      do i=1,mcnesp*6+12                                                
c         dist_sm=1.0d5
c         do k=1,mcnesp*6+12                                             
c            if (k.ne.i) then
c               dis0=0.d0
c               do j=1,mcnicd
c                  dis0=dis0+(qd0_p12(j,k)-qd0_p12(j,i))**2.d0           
c               enddo
c               dist0 = dsqrt(dis0)
c               if (dist0.lt.dist_sm) dist_sm = dist0
c            endif
c         enddo
c         dism(i)=dist_sm
c      enddo
c
c %%%% if selected, do calculations using Shepard interpolation %%%%%%%%%%%
c
c      if (mcimre.eq.2) then
c
c     calculate the distance between the current position and every 
c     Shepard point
c
         dist_m=1.d5
         do i=1,mcnesp*6+12                                             
            diss=0.d0
            do j=1,mcnicd
               diss=diss+dqd_p12(j,i)**2.d0                             
            enddo
            distt(i)=dsqrt(diss)
            if (distt(i).lt.dist_m) dist_m = distt(i)
         enddo
c
c calculate index of es points in array distt(i)
c
           k=2
           do i=0,5
           do j=1,mcnesp
           indexes(j,i+1)=mcnesp*i+k*i+j
           enddo
           enddo
c
c loop to select generalized distances for m!N ES Schepard points
c
          do i=1,6
          do j=1,mcnesp*6
          distt_es(j,i)=distt(indexes(j,i))
          enddo
          enddo
c
c make 1-dim array
c
          ic=0
          do i=0,5
          ic=i*mcnesp
          do j=1,mcnesp
          disttes(j+ic)=distt_es(j,i+1)
          enddo
          enddo
c
c loop to select generalized distances for 2m! MM minima from array distt(i)
c
          do i=0,5
          do j=1,2
          indexmm(j,i+1)=mcnesp+j+(mcnesp+2)*i
          enddo
          enddo
c          do i=0,5
c          indexmm1(i+1)=mcnesp+1+(mcnesp+2)*i
c          indexmm1(i+1)=mcnesp+2+(mcnesp+2)*i
c          enddo
c
          do i=1,6         
          do j=1,2
          distt_mm(j,i)=distt(indexmm(j,i))
          enddo
          enddo 
c          do i=1,6
c          distt_mm1(i)=distt(indexmm1(i))
c          distt_mm2(i)=distt(indexmm2(i))
c          write (*,*) "distt_mm1,2",distt_mm1(i)
c          enddo
c
c make 1-dim array   
c
          ic=0
          do i=0,5
          ic=i*2 
          do j=1,2
          disttmm(j+ic)=distt_mm(j,i+1)
          enddo
          enddo
c 
c the reason we calculate dist_m and w(i) seperately is there may be
c more than one point with minimum distance
c
c calculate the unnormalized weight functions {w(i),i=1,mcnesp}
c and wsum
c
c when the point is very close to the interpolation point, it need to be
c treated specially to avoid divergence of the unnormalized weight function
c
        if (dist_m.le.1.d-8) then
c
c in case that the machine has strange round-off errors (?).
c
            do i=1,mcnesp*6+12                                          
c               if (distt(i).le.(dist_m+1.d-37)) w(i)=1.d0
               if (distt(i).le.dist_m) w(i)=1.d0
c              write (*,*) "distt(i).le.dist_m",distt(i),dist_m
            enddo
         else
c
c Start loop over all Shepard points including MM minima
c
            do i=1,mcnesp*6+12         
               dstnce = distt(i)
c
               if (dstnce.eq.0.0d0) then
                   w(i) = 1.00d0
               else
                   w(i) = 0.0d0
                   wca = 0.0d0
                   wcaes = 0.0d0
                   wcamm = 0.0d0
               end if
            enddo
c
c get scaling factors Fw if necessary
c
            if (iwscale.eq.0) then                                      0108OT09
                   do j=1,mcnesp*6                                      0108OT09
                      Fw(j)=1.0d0                                       0108OT09
                   enddo                                                0108OT09
            else                                                        0108OT09
                 if(icomplex.eq.1) then
                   if (mcihfr.eq.0) then
                     call mcwscales1st
                       else
                         call mcwscales                                 0108OT09
                   endif
                 else
                   call mcwscales1
                 endif
            endif                                                       0108OT09
c
                   do j=1,mcnesp*6
                      wcaes = wcaes + Fw(j)/disttes(j)**ceta            0108OT09
                   enddo
                   do j=1,12                                            0108OT09
                      wcamm =wcamm + 1.d0/disttmm(j)**ceta              0108OT09
                   enddo                                                0108OT09
                wca=wcaes+wcamm
c
            do 111  i=1,mcnesp*6
               dstnce = disttes(i)
                   wes(i) = Fw(i)/(dstnce**ceta*wca)                    0108OT09
 111     continue
            do 112 i=1,12                                               0108OT09
               dstnce = disttmm(i)                                      0108OT09
                   wmm(i) = 1.d0/(dstnce**ceta*wca)                     0108OT09
 112     continue                                                       0108OT09
c
c combine wes and wmm arrays into w array
c
           do i=0,5
           ic=mcnesp*i+2*i
            do j=1,mcnesp
              w(j+ic)=wes(j+mcnesp*i)
            enddo
            do k=1,2
              w(mcnesp+k+(mcnesp+2)*i)=wmm(k+2*i)
            enddo
           enddo
         endif
c          do i=1,mcnesp*6
c           wprint(i)=wes(i)
c          enddo
c
      return
      end
c***********************************************************************
c     mctesi1st
c***********************************************************************
c
      subroutine mctesi1st(redun)
c
      implicit double precision (a-h,o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.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 k1(mcmcar,mcmcar),
     *                 k2(mcmcar,mcmcar)
c      double precision kxint0(mcmics,mcmics),
c     *                 kxint1(mcmics,mcmics),
c     *                 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
      logical redun
c
c     Define some variables
c
      mcncar = 3*mcnatm
c
c 1030HL03s
c initialization                                                        1201HL03
        v1=zero                                                         1201HL03
        v2=zero                                                         1201HL03
        do ihai=1,mcmcar                                                1201HL03
          x0(ihai)=zero                                                 1201HL03
          d0(ihai)=zero                                                 1201HL03
          d1(ihai)=zero                                                 1201HL03
          d2(ihai)=zero                                                 1201HL03
        enddo                                                           1201HL03
c 1030HL03e                                                             1201HL03
c
c     Start a loop over the mcnesp (electronic structure theory Shepard points)
c
      do mciesp=1,mcnesp
c
c     Put the Shepard point information into the working arrays
c
         v0=vsh(mciesp)
         do i=1,mcncar
            x0(i)=xsh(i,mciesp)
            d0(i)=dsh(i,mciesp)
         enddo
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,2,1,1)
c
c     And now, the same for v2, d2, and k2:
c
          call mcviic(x0,v2,d2,k2,2,2,1)
c
c     Rearrange the Cartesian coordinates:
c
         do j = 1, mcnatm
            xc(j) = x0(3*j-2)
            yc(j) = x0(3*j-1)
            zc(j) = x0(3*j)
         end do
c
c     Transform the cartesian coordinates of the electronic structure
c     theory Shepard points nto 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 i = 1, mcnicd
            qd0(i,mciesp) = dicd(i)
         end do
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 i = 1, mcnics
            qs0(i,mciesp) = dics(i)
         end do
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  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 i = 1, mcmic2
            do j=1, mcmics
               amatbt(j,i) = zero
            enddo
         end do
         call ybtens (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,
     *                mcidas,mciads,xc,yc,zc,mcnatm,amatbi,
     *                amatbt,mcnics,mcncar,mcmics,mcmic2,mcmatm,t)
c
c     Now calculated the differences: g-gk and f-fk : 6/9/99 by Y. Kim
c
        if (mcihfr.ne.0) then
         do i=1,mcnics
            dxint1(i) = dxint1(i) - dxint0(i)
            dxint2(i) = dxint2(i) - dxint0(i)
         enddo
        else
                  do i=1,mcnics
            dxint1(i) = dxint1(i) - dxint0(i)
            dxint2(i) = dxint2(i) - dxint0(i)
                   enddo
        endif

c     Calculation of A (scalar)
c
         va = (v1-v0)
         vb = (v2-v0)
         aevbm(mciesp) = va*vb
c
c     Calculation of B (vector)
c
         do i=1,mcnics
            bevbm(i,mciesp) = dxint1(i)/va + dxint2(i)/vb
         enddo
c
c     End of the loop over the mcnesp points
c
      enddo
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
c
      return
      end
c***********************************************************************
c     mctesi
c***********************************************************************
c
      subroutine mctesi(redun)
c
c     Subroutine to tranformed the information from the input file esp.fu83
c     into internal coordinates.
c
c     This is a modified version of subroutine rdk in Tinkerate.
c     Subroutine rdk in Tinkerate uses the evb expression by Chang and
c     Miller, J. Phys. Chem. 94, 5884, 1990. The notation is the same as
c     in the paper. Modified by J. Xing on May 8, 1998 for Shepard
c     interpolation used in IVTST-M/MCMM. Revised for internal coordinates
c     by 0521JX98, revisioned 11/10/99 by Yongho Kim, and modified by TVA
c     on 10/16/00 to include the internal coordinates used for generalized
c     distances but not for Shepard interpolation. The mctesi is finally
c     modified again by TVA for using it in MC-TINKER.
c     Some of the variables (e.g., ggi, flgm, egnm, etc.) are not used but
c     are left in so it will use the same subroutines as before.
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
      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
      logical redun
c
c     Define some variables
c
      mcncar = 3*mcnatm
c
c 1030HL03s
c initialization                                                        1201HL03
        v1=zero                                                         1201HL03
        v2=zero                                                         1201HL03
        do ihai=1,mcmcar                                                1201HL03
          x0(ihai)=zero                                                 1201HL03
          d0(ihai)=zero                                                 1201HL03
          d1(ihai)=zero                                                 1201HL03
          d2(ihai)=zero                                                 1201HL03
          do jhai=1,mcmcar                                              1201HL03
            k0(ihai,jhai)=zero                                          1201HL03
            k1(ihai,jhai)=zero                                          1201HL03
            k2(ihai,jhai)=zero                                          1201HL03
          enddo                                                         1201HL03
        enddo                                                           1201HL03
c 1030HL03e                                                             1201HL03
c
c     Start a loop over the mcnesp (electronic structure theory Shepard points)
c
      do mciesp=1,mcnesp
c
c     Put the Shepard point information into the working arrays
c
         v0=vsh(mciesp)
         do i=1,mcncar
            x0(i)=xsh(i,mciesp)
            d0(i)=dsh(i,mciesp)
            do j=1,mcncar
               k0(i,j)=hsh(i,j,mciesp)
            enddo
         enddo
c
c     Now transform the information into internal coordinates
c
c
c     Calculate v1, d1 and k1 by means of a mcviic call.
c
         if (mcihfr.eq.4) then
          call mcviic(x0,v1,d1,k1,2,1,1)
         else
          call mcviic(x0,v1,d1,k1,3,1,1)
         endif
c
c     And now, the same for v2, d2, and k2:
c
         if (mcihfr.eq.4) then
          call mcviic(x0,v2,d2,k2,2,2,1)
         else
          call mcviic(x0,v2,d2,k2,3,2,1)
         endif
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)                                   1201HL03
c 1031HL03e
c
c     Rearrange the Cartesian coordinates:
c
         do j = 1, mcnatm
            xc(j) = x0(3*j-2)
            yc(j) = x0(3*j-1)
            zc(j) = x0(3*j)
         end do
c
c     Transform the cartesian coordinates of the electronic structure
c     theory Shepard points nto 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 i = 1, mcnicd
            qd0(i,mciesp) = dicd(i)
         end do
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 i = 1, mcnics
            qs0(i,mciesp) = dics(i)
         end do
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  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 i = 1, mcmic2
            do j=1, mcmics
               amatbt(j,i) = zero
            enddo
         end do
         call ybtens (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,
     *                mcidas,mciads,xc,yc,zc,mcnatm,amatbi,
     *                amatbt,mcnics,mcncar,mcmics,mcmic2,mcmatm,t)
c
         if (mcihfr.ne.4) then
c
c     K0
c
         do i = 1, mcmic2
            amatc(i) = zero
         end do
         call formf2ij (amatc,amatbt,dxint0,mcmics,mcmic2,mcnics)
         do i = 1, mcmic2
            scr3(i) = zero
         end do
         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 i = 1, mcmic2
            amatc(i) = zero
         end do
         call formf2ij (amatc,amatbt,dxint1,mcmics,mcmic2,mcnics)
         do i = 1, mcmic2
            scr3(i) = zero
         end do
         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 i = 1, mcmic2
            amatc(i) = zero
         end do
         call formf2ij (amatc,amatbt,dxint2,mcmics,mcmic2,mcnics)
         do i = 1, mcmic2
            scr3(i) = zero
         end do
         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
         endif
c
c     Now calculated the differences: g-gk and f-fk : 6/9/99 by Y. Kim
c
        if (mcihfr.ne.4) then
         do i=1,mcnics
            dxint1(i) = dxint1(i) - dxint0(i)
            dxint2(i) = dxint2(i) - dxint0(i)
               do j=1,mcnics
                  kxint1(j,i) = kxint1(j,i) - kxint0(j,i)
                  kxint2(j,i) = kxint2(j,i) - kxint0(j,i)
               enddo
         enddo
        else
                  do i=1,mcnics
            dxint1(i) = dxint1(i) - dxint0(i)
            dxint2(i) = dxint2(i) - dxint0(i)
                   enddo
        endif

c     Calculation of A (scalar)
c
         va = (v1-v0)
         vb = (v2-v0)
         aevbm(mciesp) = va*vb
c
c     Calculation of B (vector)
c
         do i=1,mcnics
            bevbm(i,mciesp) = dxint1(i)/va + dxint2(i)/vb
         enddo
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 j=1,mcnics
              do 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)
              enddo
           enddo
c
c     and mcifre=2
c
        else if (mcifre.eq.2)then
c
         if (mcihfr.eq.4) then
c
           do j=1,mcnics
              do i=1,mcnics
                 cevbm(i,j,mciesp)=(dxint1(i)*dxint2(j))/(va*vb)+                1106OT06
     *                             (dxint2(i)*dxint1(j))/(va*vb)                 1106OT06
              enddo
           enddo
         else
           do j=1,mcnics
              do i=1,mcnics
                 cevbm(i,j,mciesp)=(dxint1(i)*dxint2(j))/(va*vb)+                1106OT06
     *                             (dxint2(i)*dxint1(j))/(va*vb)+                1106OT06
     *                             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
              enddo
           enddo
         endif
c
        endif
c
c     End of the loop over the mcnesp points
c
c       do i=1,mcnics
c          do j=1,mcnics
c            write (6,*) "cevbm", cevbm(i,j,k),mcihfr,dxint1(1)
c          enddo
c       enddo
      enddo
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     mctesis1st
c***********************************************************************
c
      subroutine mctesis1st(redun)
c
c     This subroutine is analogous to mctesi. It calculates the D, b, and C
c     coefficients for each symmetrically equivalent Shepard point.
c     (O.T. October 2006)
c
      implicit double precision (a-h,o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      parameter (zero   = 0.0d0 )  
      parameter (mcmca2=mcmcar*(mcmcar+1)/2)
      parameter (mcmic2=mcmics*(mcmics+1)/2)
c
      dimension x0(mcmcar)                  
      dimension x0_12(mcmcar)                                           
      dimension x0_23(mcmcar)                                           
      dimension x0_13(mcmcar)                                           
      dimension x0_123(mcmcar)                                          
      dimension x0_132(mcmcar)                                          
      dimension d0(mcmcar),d1(mcmcar),d2(mcmcar)                        
      dimension d0_E(mcmcar),d1_E(mcmcar),d2_E(mcmcar)                  
      dimension d0_12(mcmcar),d1_12(mcmcar),d2_12(mcmcar)               
      dimension d0_23(mcmcar),d1_23(mcmcar),d2_23(mcmcar)               
      dimension d0_13(mcmcar),d1_13(mcmcar),d2_13(mcmcar)                
      dimension d0_123(mcmcar),d1_123(mcmcar),d2_123(mcmcar)            
      dimension d0_132(mcmcar),d1_132(mcmcar),d2_132(mcmcar)            
      dimension d1tmp(mcmcar),d2tmp(mcmcar)                             
      dimension d1av12(mcmcar),d2av12(mcmcar)                           
      dimension d1av23(mcmcar),d2av23(mcmcar)                           
      dimension d1av13(mcmcar),d2av13(mcmcar)                           
      dimension d1av123(mcmcar),d2av123(mcmcar)                         
      dimension d1av132(mcmcar),d2av132(mcmcar)                         
      dimension dxint0(mcmics),dxint1(mcmics),dxint2(mcmics)            
      dimension dxint0_12(mcmics),dxint1_12(mcmics),dxint2_12(mcmics)   
      dimension dxint0_23(mcmics),dxint1_23(mcmics),dxint2_23(mcmics)   
      dimension dxint0_13(mcmics),dxint1_13(mcmics),dxint2_13(mcmics)   
      dimension dxint0_123(mcmics),dxint1_123(mcmics),dxint2_123(mcmics)
      dimension dxint0_132(mcmics),dxint1_132(mcmics),dxint2_132(mcmics)
      dimension dxint1avE(mcmics)                                       
      dimension dxint1av12(mcmics),dxint1av23(mcmics),dxint1av13(mcmics)
      dimension dxint1av123(mcmics), dxint1av132(mcmics)                
      dimension dxint2av12(mcmics),dxint2av23(mcmics)                   
      dimension dxint2avE(mcmics)                                       
      dimension dxint2av13(mcmics),dxint2av123(mcmics)                  
      dimension dxint2av132(mcmics)                                     
c
      double precision 
     *                 k1(mcmcar,mcmcar),
     *                 k2(mcmcar,mcmcar),
     *                 xlooker1(mcmcar,mcmcar),                         
     *                 xlooker2(mcmcar,mcmcar),                         
     *                 xlooker3(mcmcar,mcmcar),                         
     *                 xlooker3a(mcmcar,mcmcar),                        
     *                 xlooker4(mcmcar,mcmcar),                         
     *                 xlooker5(mcmcar,mcmcar)
c
      dimension dics(mcmics)
      dimension dics_12(mcmics)                                         
      dimension dics_23(mcmics)                                         
      dimension dics_13(mcmics)                                         
      dimension dics_123(mcmics)                                        
      dimension dics_132(mcmics)                                        
      dimension dicd(mcmicd)
      dimension dicd_12(mcmicd)                                         
      dimension dicd_23(mcmicd)                                         
      dimension dicd_13(mcmicd)                                         
      dimension dicd_123(mcmicd)                                        
      dimension dicd_132(mcmicd)                                        
      dimension xc(mcmatm),yc(mcmatm),zc(mcmatm)
      dimension xc_12(mcmatm),yc_12(mcmatm),zc_12(mcmatm)               
      dimension xc_23(mcmatm),yc_23(mcmatm),zc_23(mcmatm)               
      dimension xc_13(mcmatm),yc_13(mcmatm),zc_13(mcmatm)               
      dimension xc_123(mcmatm),yc_123(mcmatm),zc_123(mcmatm)            
      dimension xc_132(mcmatm),yc_132(mcmatm),zc_132(mcmatm)            
      dimension amatb(mcmics,mcmcar)
      dimension amatb_12(mcmics,mcmcar)                                 
      dimension amatb_23(mcmics,mcmcar)                                 
      dimension amatb_13(mcmics,mcmcar)                                 
      dimension amatb_123(mcmics,mcmcar)                                
      dimension amatb_132(mcmics,mcmcar)                                
      dimension amatbi(mcmcar,mcmics)
      dimension amatbi_12(mcmcar,mcmics)                                
      dimension amatbi_23(mcmcar,mcmics)                                
      dimension amatbi_13(mcmcar,mcmics)                                
      dimension amatbi_123(mcmcar,mcmics)                               
      dimension amatbi_132(mcmcar,mcmics)                               
      dimension amatbt(mcmics,mcmic2)
      dimension amatbt_12(mcmics,mcmic2)                                
      dimension amatbt_23(mcmics,mcmic2)                                
      dimension amatbt_13(mcmics,mcmic2)                                
      dimension amatbt_123(mcmics,mcmic2)                               
      dimension amatbt_132(mcmics,mcmic2)                               
      dimension amatc(mcmic2)
      dimension amatc_12(mcmic2)                                        
      dimension amatc_23(mcmic2)                                        
      dimension amatc_13(mcmic2)                                        
      dimension amatc_123(mcmic2)                                       
      dimension amatc_132(mcmic2)                                       
      dimension egnm(mcmics,mcmics) 
      dimension egnm_12(mcmics,mcmics)                                  
      dimension egnm_23(mcmics,mcmics)                                  
      dimension egnm_13(mcmics,mcmics)                                  
      dimension egnm_123(mcmics,mcmics)                                 
      dimension egnm_132(mcmics,mcmics)                                 
      dimension ggi(mcmics,mcmics)
      dimension ggi_12(mcmics,mcmics)                                   
      dimension ggi_23(mcmics,mcmics)                                   
      dimension ggi_13(mcmics,mcmics)                                   
      dimension ggi_123(mcmics,mcmics)                                  
      dimension ggi_132(mcmics,mcmics)                                  
      dimension gm(mcmics,mcmics)
      dimension amasin(mcmcar,mcmcar)
      dimension amasin_12(mcmcar,mcmcar)                                
      dimension amasin_23(mcmcar,mcmcar)                                
      dimension amasin_13(mcmcar,mcmcar)                                
      dimension amasin_123(mcmcar,mcmcar)                               
      dimension amasin_132(mcmcar,mcmcar)                               
      dimension flgm(mcmics)
      dimension scr(mcmcar,mcmics)
      dimension scr_12(mcmcar,mcmics)                                   
      dimension scr_23(mcmcar,mcmics)                                   
      dimension scr_13(mcmcar,mcmics)                                   
      dimension scr_123(mcmcar,mcmics)                                  
      dimension scr_132(mcmcar,mcmics)                                  
      dimension scr3(mcmic2)
      dimension scr3_12(mcmic2)                                         
      dimension scr3_23(mcmic2)                                         
      dimension scr3_13(mcmic2)                                         
      dimension scr3_123(mcmic2)                                        
      dimension scr3_132(mcmic2)                                        
      dimension fl(mcmca2)
      dimension fl_12(mcmca2)                                           
      dimension fl_23(mcmca2)                                           
      dimension fl_13(mcmca2)                                           
      dimension fl_123(mcmca2)                                          
      dimension fl_132(mcmca2)                                          
c
      logical redun
c
c     Define some variables
c
      mcncar = 3*mcnatm
c
c initialization                                                        
        v1=zero                                                         
        v2=zero                                                         
        v1_E=zero                                                       
        v1_12=zero                                                      
        v1_23=zero                                                      
        v1_13=zero                                                      
        v1_123=zero                                                     
        v1_132=zero                                                     
        v2_E=zero                                                       
        v2_12=zero                                                      
        v2_23=zero                                                      
        v2_13=zero                                                      
        v2_123=zero                                                     
        v2_132=zero                                                     
        expsum=zero                                                     
        expsum_2=zero                                                   
        do i=1,mcmics
            dxint0(i)=zero
            dxint0_12(i)=zero                                           
            dxint0_23(i)=zero                                           
            dxint0_13(i)=zero                                           
            dxint0_123(i)=zero                                          
            dxint0_132(i)=zero                                          
            dxint1(i)=zero
            dxint1_12(i)=zero                                           
            dxint1_23(i)=zero                                           
            dxint1_13(i)=zero                                           
            dxint1_123(i)=zero                                          
            dxint1_132(i)=zero                                          
            dxint2(i)=zero
            dxint2_12(i)=zero                                           
            dxint2_23(i)=zero                                           
            dxint2_13(i)=zero                                           
            dxint2_123(i)=zero                                          
            dxint2_132(i)=zero                                          
            dxint1avE(i)=zero                                           
            dxint1av12(i)=zero                                          
            dxint1av23(i)=zero                                          
            dxint1av13(i)=zero                                          
            dxint1av123(i)=zero                                         
            dxint1av132(i)=zero                                         
            dxint2avE(i)=zero                                           
            dxint2av12(i)=zero                                           
            dxint2av23(i)=zero                                          
            dxint2av13(i)=zero                                          
            dxint2av123(i)=zero                                         
            dxint2av132(i)=zero                                         
        enddo 
        do ih=1,mcmcar                                                
          x0(ih)=zero                                                 
          x0_12(ih)=zero                                              
          x0_23(ih)=zero                                              
          x0_13(ih)=zero                                              
          x0_123(ih)=zero                                             
          x0_132(ih)=zero                                             
          d0(ih)=zero                                                 
          d0_12(ih)=zero                                              
          d0_23(ih)=zero                                              
          d0_13(ih)=zero                                              
          d0_123(ih)=zero                                             
          d0_132(ih)=zero                                             
          d1(ih)=zero                                                 
          d1_E(ih)=zero                                               
          d1_12(ih)=zero                                              
          d1_23(ih)=zero                                              
          d1_13(ih)=zero                                              
          d1_123(ih)=zero                                             
          d1_132(ih)=zero                                             
          d1tmp(ih)=zero                                              
          d1av12(ih)=zero                                             
          d1av23(ih)=zero                                             
          d1av13(ih)=zero                                             
          d1av123(ih)=zero                                            
          d1av132(ih)=zero                                            
          d2av12(ih)=zero                                             
          d2av23(ih)=zero                                             
          d2av13(ih)=zero                                             
          d2av123(ih)=zero                                            
          d2av132(ih)=zero                                            
          d2(ih)=zero                                                 
          d2_E(ih)=zero                                               
          d2_12(ih)=zero                                              
          d2_23(ih)=zero                                              
          d2_13(ih)=zero                                              
          d2_123(ih)=zero                                             
          d2_132(ih)=zero                                             
          do jh=1,mcmcar                                              
            k1(ih,jh)=zero                                          
            k2(ih,jh)=zero                                          
            xlooker1(ih,jh)=zero                                    
            xlooker2(ih,jh)=zero                                    
            xlooker3(ih,jh)=zero                                    
            xlooker3a(ih,jh)=zero                                   
            xlooker4(ih,jh)=zero                                    
            xlooker5(ih,jh)=zero                                    
          enddo                                                         
        enddo                                                           
c
c     Start a loop over the mcnesp (electronic structure theory Shepard points)
c
      do mciesp=1,mcnesp
c
c     Put the Shepard point information into the working arrays
c
         v0=vsh(mciesp)
         do i=1,mcncar
            x0(i)=xsh(i,mciesp)
            d0(i)=dsh(i,mciesp)
         enddo
c Permutation of rows in arrays with Shepard point geom and grad        
          call mc12perm(x0_12,x0)                                       
          call mc12perm(d0_12,d0)                                       
          call mc23perm(x0_23,x0)                                        
          call mc23perm(d0_23,d0)                                       
          call mc13perm(x0_13,x0)                                       
          call mc13perm(d0_13,d0)                                       
          call mc123perm(x0_123,x0)                                     
          call mc123perm(d0_123,d0)                                     
          call mc132perm(x0_132,x0)                                     
          call mc132perm(d0_132,d0)                                     
c
c     Calculate v1, d1 and k1 by means of a mcviic call.
cOT  These are now calculated n!=6 times for each permutation.          
c
         call mcviic(x0,v1_E,d1_E,k1,2,1,1)                             
         call mcviic(x0_12,v1_12,d1_12,k1,2,1,1)                         
         call mcviic(x0_23,v1_23,d1_23,k1,2,1,1)                         
         call mcviic(x0_13,v1_13,d1_13,k1,2,1,1)                         
         call mcviic(x0_123,v1_123,d1_123,k1,2,1,1)                     
         call mcviic(x0_132,v1_132,d1_132,k1,2,1,1)                     
c
         exxp1 = dexp(-alphaV1*v1_E)                                    
         exxp2 = dexp(-alphaV1*v1_12)                                   
         exxp3 = dexp(-alphaV1*v1_23)                                   
         exxp4 = dexp(-alphaV1*v1_13)                                   
         exxp5 = dexp(-alphaV1*v1_123)                                  
         exxp6 = dexp(-alphaV1*v1_132)                                  
c
         v1=-(1.d0/alphaV1)*dlog(1.d0/isigmav1*(exxp1+exxp2             
     *   +exxp3+exxp4+exxp5+exxp6))                                     
c
         expsum=exxp1+exxp2+exxp3+exxp4+exxp5+exxp6                     
c
c Symmetrized gradient (\tilde{G})
         do i=1,12                                                      
          d1tmp(i)=exxp1*d1_E(i)+exxp2*d1_12(i)+exxp3*d1_23(i)          
     *    +exxp4*d1_13(i)+exxp5*d1_123(i)+exxp6*d1_132(i)               
           d1(i)=d1tmp(i)/expsum                                        
         enddo                                                          
c
          call mc12perm (d1av12,d1)                                     
          call mc23perm (d1av23,d1)                                     
          call mc13perm (d1av13,d1)                                     
          call mc123perm (d1av123,d1)                                   
          call mc132perm (d1av132,d1)                                   
c
c     And now, the same for v2, d2, and k2:
c
         expsum=0.d0                                                    
         expsum_2=0.d0                                                  
         call mcviic(x0,v2_E,d2_E,k2,2,2,1)                             
         call mcviic(x0_12,v2_12,d2_12,k2,2,2,1)                         
         call mcviic(x0_23,v2_23,d2_23,k2,2,2,1)                         
         call mcviic(x0_13,v2_13,d2_13,k2,2,2,1)                         
         call mcviic(x0_123,v2_123,d2_123,k2,2,2,1)                     
         call mcviic(x0_132,v2_132,d2_132,k2,2,2,1)                     
         exxp1_2 = dexp(-alphaV2*v2_E)                                  
         exxp2_2 = dexp(-alphaV2*v2_12)                                 
         exxp3_2= dexp(-alphaV2*v2_23)                                  
         exxp4_2= dexp(-alphaV2*v2_13)                                  
         exxp5_2= dexp(-alphaV2*v2_123)                                 
         exxp6_2= dexp(-alphaV2*v2_132)                                 
         v2=-(1.d0/alphaV2)*dlog(1.d0/isigmav2*(exxp1_2+exxp2_2+         
     *   exxp3_2+exxp4_2+exxp5_2+exxp6_2))                              
c
         expsum_2=exxp1_2+exxp2_2+exxp3_2+exxp4_2+exxp5+exxp6_2         
c
c Symmetrized gradient (\tilde{G_2})
         do i=1,12                                                      
          d2tmp(i)=exxp1_2*d2_E(i)+exxp2_2*d2_12(i)+exxp3_2*d2_23(i)    
     *    +exxp4_2*d2_13(i)+exxp5_2*d2_123(i)+exxp6_2*d2_132(i)         
           d2(i)=d2tmp(i)/expsum_2                                      
         enddo                                                          
c
c   d2_av_12(i) is the gradient at the "reflected" (k)-point            
          call mc12perm (d2av12,d2)                                     
          call mc23perm (d2av23,d2)                                     
          call mc13perm (d2av13,d2)                                     
          call mc123perm (d2av123,d2)                                   
          call mc132perm (d2av132,d2)                                   
c         
         do i=1,mcmcar                                                  
         do j=1,mcmcar                                                  
         xlooker1(i,j)=0.d0                                             
         xlooker2(i,j)=0.d0                                             
         xlooker3(i,j)=0.d0                                             
         xlooker3a(i,j)=0.d0                                            
         xlooker4(i,j)=0.d0                                             
         xlooker5(i,j)=0.d0                                             
        enddo                                                           
         enddo                                                          
c
c     Rearrange the Cartesian coordinates:
c
         do j = 1, mcnatm
            xc(j) = x0(3*j-2)
            yc(j) = x0(3*j-1)
            zc(j) = x0(3*j)
            xc_12(j) = x0_12(3*j-2)                                     
            yc_12(j) = x0_12(3*j-1)                                     
            zc_12(j) = x0_12(3*j)                                       
            xc_23(j) = x0_23(3*j-2)                                     
            yc_23(j) = x0_23(3*j-1)                                     
            zc_23(j) = x0_23(3*j)                                       
            xc_13(j) = x0_13(3*j-2)                                          
            yc_13(j) = x0_13(3*j-1)                                     
            zc_13(j) = x0_13(3*j)                                        
            xc_123(j) = x0_123(3*j-2)                                   
            yc_123(j) = x0_123(3*j-1)                                   
            zc_123(j) = x0_123(3*j)                                     
            xc_132(j) = x0_132(3*j-2)                                   
            yc_132(j) = x0_132(3*j-1)                                   
            zc_132(j) = x0_132(3*j)                                     
         end do
c
c     Transform the cartesian coordinates of the electronic structure
c     theory Shepard points nto 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)
         call mctcic(mcndid,mcnand,mcnadd,mcndad,                       
     *               mcidid,mciand,mciadd,mcidad,                       
     *         mcmicd,mcmatm,xc_12,yc_12,zc_12,dicd_12)                 
         call mctcic(mcndid,mcnand,mcnadd,mcndad,                       
     *               mcidid,mciand,mciadd,mcidad,                       
     *         mcmicd,mcmatm,xc_23,yc_23,zc_23,dicd_23)                 
         call mctcic(mcndid,mcnand,mcnadd,mcndad,                       
     *               mcidid,mciand,mciadd,mcidad,                       
     *         mcmicd,mcmatm,xc_13,yc_13,zc_13,dicd_13)                 
         call mctcic(mcndid,mcnand,mcnadd,mcndad,                       
     *               mcidid,mciand,mciadd,mcidad,                       
     *         mcmicd,mcmatm,xc_123,yc_123,zc_123,dicd_123)             
         call mctcic(mcndid,mcnand,mcnadd,mcndad,                       
     *               mcidid,mciand,mciadd,mcidad,                       
     *         mcmicd,mcmatm,xc_132,yc_132,zc_132,dicd_132)             
         do i = 1, mcnicd
            qd0(i,mciesp) = dicd(i)
            qd0_12(i,mciesp) = dicd_12(i)                               
            qd0_23(i,mciesp) = dicd_23(i)                               
            qd0_13(i,mciesp) = dicd_13(i)                               
            qd0_123(i,mciesp) = dicd_123(i)                             
            qd0_132(i,mciesp) = dicd_132(i)                             
         end do
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)
         call mctcic(mcndis,mcnans,mcnads,mcndas,                       
     *               mcidis,mcians,mciads,mcidas,                       
     *          mcmics,mcmatm,xc_12,yc_12,zc_12,dics_12)                
         call mctcic(mcndis,mcnans,mcnads,mcndas,                       
     *               mcidis,mcians,mciads,mcidas,                       
     *          mcmics,mcmatm,xc_23,yc_23,zc_23,dics_23)                
         call mctcic(mcndis,mcnans,mcnads,mcndas,                       
     *               mcidis,mcians,mciads,mcidas,                       
     *          mcmics,mcmatm,xc_13,yc_13,zc_13,dics_13)                
         call mctcic(mcndis,mcnans,mcnads,mcndas,                       
     *               mcidis,mcians,mciads,mcidas,                       
     *      mcmics,mcmatm,xc_123,yc_123,zc_123,dics_123)                
         call mctcic(mcndis,mcnans,mcnads,mcndas,                       
     *               mcidis,mcians,mciads,mcidas,                       
     *      mcmics,mcmatm,xc_132,yc_132,zc_132,dics_132)                
         do i = 1, mcnics
            qs0(i,mciesp) = dics(i)
            qs0_12(i,mciesp) = dics_12(i)                               
            qs0_23(i,mciesp) = dics_23(i)                               
            qs0_13(i,mciesp) = dics_13(i)                               
            qs0_123(i,mciesp) = dics_123(i)                             
            qs0_132(i,mciesp) = dics_132(i)                             
         end do
         call mcybmat (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,
     *                 mcidas,mciads,xc,yc,zc,mcnatm,mcnics,
     *                 amatb,t,mcmatm,mcmics,mcmcar)
         call mcybmat (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,       
     *             mcidas,mciads,xc_12,yc_12,zc_12,mcnatm,mcnics,       
     *                 amatb_12,t,mcmatm,mcmics,mcmcar)                 
         call mcybmat (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,       
     *             mcidas,mciads,xc_23,yc_23,zc_23,mcnatm,mcnics,       
     *                 amatb_23,t,mcmatm,mcmics,mcmcar)                 
         call mcybmat (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,       
     *             mcidas,mciads,xc_13,yc_13,zc_13,mcnatm,mcnics,       
     *                 amatb_13,t,mcmatm,mcmics,mcmcar)                 
         call mcybmat (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,       
     *             mcidas,mciads,xc_123,yc_123,zc_123,mcnatm,mcnics,    
     *                 amatb_123,t,mcmatm,mcmics,mcmcar)                
         call mcybmat (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,       
     *             mcidas,mciads,xc_132,yc_132,zc_132,mcnatm,mcnics,    
     *                 amatb_132,t,mcmatm,mcmics,mcmcar)                
c
c  2) compute the A matrix
cOT 
c         redun=.true.
c
         if (redun) then
            call mcybimat2 (amatb,amatbi,cmmc,amasin,gm,ggi,flgm,
     *                      egnm,smmc,mcnatm,mcnics,mcmics,mcmcar)
            call mcybimat2 (amatb_12,amatbi_12,cmmc,amasin,gm,          
     *                      ggi,flgm,                                   
     *                      egnm,smmc,mcnatm,mcnics,mcmics,mcmcar)      
            call mcybimat2 (amatb_23,amatbi_23,cmmc,amasin,gm,          
     *                      ggi,flgm,                                   
     *                      egnm,smmc,mcnatm,mcnics,mcmics,mcmcar)      
            call mcybimat2 (amatb_13,amatbi_13,cmmc,amasin,gm,          
     *                      ggi,flgm,                                   
     *                      egnm,smmc,mcnatm,mcnics,mcmics,mcmcar)      
        call mcybimat2 (amatb_123,amatbi_123,cmmc,amasin,gm,            
     *                      ggi,flgm,                                   
     *                      egnm,smmc,mcnatm,mcnics,mcmics,mcmcar)      
        call mcybimat2 (amatb_132,amatbi_132,cmmc,amasin,gm,            
     *                      ggi,flgm,                                   
     *                      egnm,smmc,mcnatm,mcnics,mcmics,mcmcar)      
         else
            call mcybimat (amatb,amatbi,cmmc,amasin,gm,smmc,
     *                     mcnatm,mcnics,mcmics,mcmcar)
            call mcybimat (amatb_12,amatbi_12,cmmc,amasin,gm,smmc,      
     *                     mcnatm,mcnics,mcmics,mcmcar)                 
            call mcybimat (amatb_23,amatbi_23,cmmc,amasin,gm,smmc,      
     *                     mcnatm,mcnics,mcmics,mcmcar)                 
            call mcybimat (amatb_13,amatbi_13,cmmc,amasin,gm,smmc,      
     *                     mcnatm,mcnics,mcmics,mcmcar)                 
        call mcybimat (amatb_123,amatbi_123,cmmc,amasin,gm,smmc,        
     *                     mcnatm,mcnics,mcmics,mcmcar)                 
        call mcybimat (amatb_132,amatbi_132,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 (dxint0_12,amatbi_12,d0_12,mcnics,mcncar,mcmics,   
     *                mcmcar)                                           
         call trangj (dxint0_23,amatbi_23,d0_23,mcnics,mcncar,mcmics,   
     *                mcmcar)                                           
         call trangj (dxint0_13,amatbi_13,d0_13,mcnics,mcncar,mcmics,   
     *                mcmcar)                                           
         call trangj (dxint0_123,amatbi_123,d0_123,mcnics,mcncar,mcmics,
     *                mcmcar)                                           
         call trangj (dxint0_132,amatbi_132,d0_132,mcnics,mcncar,mcmics,
     *                mcmcar)                                           
c
        call trangj (dxint1avE,amatbi,d1,mcnics,mcncar,mcmics,mcmcar)   
        call trangj (dxint1av12,amatbi_12,d1av12,mcnics,mcncar,         
     *              mcmics,mcmcar)                                      
        call trangj (dxint1av23,amatbi_23,d1av23,mcnics,mcncar,         
     *              mcmics,mcmcar)                                      
        call trangj (dxint1av13,amatbi_13,d1av13,mcnics,mcncar,         
     *              mcmics,mcmcar)                                      
        call trangj (dxint1av123,amatbi_123,d1av123,mcnics,mcncar,      
     *              mcmics,mcmcar)                                      
        call trangj (dxint1av132,amatbi_132,d1av132,mcnics,mcncar,      
     *              mcmics,mcmcar)                                      
        call trangj (dxint2avE,amatbi,d2,mcnics,mcncar,mcmics,mcmcar)   
        call trangj (dxint2av12,amatbi_12,d2av12,mcnics,mcncar,         
     *              mcmics,mcmcar)                                      
        call trangj (dxint2av23,amatbi_23,d2av23,mcnics,mcncar,         
     *              mcmics,mcmcar)                                      
        call trangj (dxint2av13,amatbi_13,d2av13,mcnics,mcncar,         
     *              mcmics,mcmcar)                                      
        call trangj (dxint2av123,amatbi_123,d2av123,mcnics,mcncar,      
     *              mcmics,mcmcar)                                      
        call trangj (dxint2av132,amatbi_132,d2av132,mcnics,mcncar,      
     *              mcmics,mcmcar)                                      
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 i = 1, mcmic2
            do j=1, mcmics
               amatbt(j,i) = zero
            enddo
         end do
         call ybtens (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,
     *                mcidas,mciads,xc,yc,zc,mcnatm,amatbi,
     *                amatbt,mcnics,mcncar,mcmics,mcmic2,mcmatm,t)
c
         do i = 1, mcmic2                                               
            do j=1, mcmics                                              
               amatbt_12(j,i) = zero                                    
            enddo                                                       
         end do                                                         
         call ybtens (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,        
     *              mcidas,mciads,xc_12,yc_12,zc_12,mcnatm,amatbi_12,   
     *              amatbt_12,mcnics,mcncar,mcmics,mcmic2,mcmatm,t_12)  
c         
         do i = 1, mcmic2                                               
            do j=1, mcmics                                              
               amatbt_23(j,i) = zero                                    
            enddo                                                       
         end do                                                         
         call ybtens (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,        
     *              mcidas,mciads,xc_23,yc_23,zc_23,mcnatm,amatbi_23,   
     *              amatbt_23,mcnics,mcncar,mcmics,mcmic2,mcmatm,t_23)  
c         
         do i = 1, mcmic2                                               
            do j=1, mcmics                                              
               amatbt_13(j,i) = zero                                    
            enddo                                                       
         end do                                                         
         call ybtens (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,        
     *              mcidas,mciads,xc_13,yc_13,zc_13,mcnatm,amatbi_13,   
     *              amatbt_13,mcnics,mcncar,mcmics,mcmic2,mcmatm,t_13)  
c         
         do i = 1, mcmic2                                               
            do j=1, mcmics                                              
               amatbt_123(j,i) = zero                                   
            enddo                                                       
         end do                                                         
         call ybtens (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,        
     *        mcidas,mciads,xc_123,yc_123,zc_123,mcnatm,amatbi_123,     
     *        amatbt_123,mcnics,mcncar,mcmics,mcmic2,mcmatm,t_123)      
c         
         do i = 1, mcmic2                                               
            do j=1, mcmics                                              
               amatbt_132(j,i) = zero                                   
            enddo                                                       
         end do                                                         
         call ybtens (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,        
     *        mcidas,mciads,xc_132,yc_132,zc_132,mcnatm,amatbi_132,     
     *        amatbt_132,mcnics,mcncar,mcmics,mcmic2,mcmatm,t_132)      
c
c
c     Now calculated the differences: g-gk and f-fk : 6/9/99 by Y. Kim
c
         do i=1,mcnics
            dxint1(i) = dxint1avE(i) - dxint0(i)
            dxint1_12(i) = dxint1av12(i) - dxint0_12(i)                 
            dxint1_23(i) = dxint1av23(i) - dxint0_23(i)                 
            dxint1_13(i) = dxint1av13(i) - dxint0_13(i)                 
            dxint1_123(i) = dxint1av123(i) - dxint0_123(i)              
            dxint1_132(i) = dxint1av132(i) - dxint0_132(i)              
c
            dxint2(i) = dxint2avE(i) - dxint0(i)
            dxint2_12(i) = dxint2av12(i) - dxint0_12(i)                 
            dxint2_23(i) = dxint2av23(i) - dxint0_23(i)                 
            dxint2_13(i) = dxint2av13(i) - dxint0_13(i)                 
            dxint2_123(i) = dxint2av123(i) - dxint0_123(i)              
            dxint2_132(i) = dxint2av132(i) - dxint0_132(i)              
         enddo
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 i=1,mcnics
            bevbm(i,mciesp) = dxint1(i)/va + dxint2(i)/vb
         enddo
         do i=1,mcnics                                                  
            bevbm_12(i,mciesp) = dxint1_12(i)/va +                      
     *                           dxint2_12(i)/vb                        
         enddo                                                          
         do i=1,mcnics                                                  
            bevbm_23(i,mciesp) = dxint1_23(i)/va +                      
     *                           dxint2_23(i)/vb                        
         enddo                                                          
         do i=1,mcnics                                                  
            bevbm_13(i,mciesp) = dxint1_13(i)/va +                      
     *                           dxint2_13(i)/vb                        
         enddo                                                          
         do i=1,mcnics                                                  
            bevbm_123(i,mciesp) = dxint1_123(i)/va +                    
     *                           dxint2_123(i)/vb                       
         enddo                                                          
         do i=1,mcnics                                                  
            bevbm_132(i,mciesp) = dxint1_132(i)/va +                    
     *                           dxint2_132(i)/vb                       
         enddo                                                          
c
c     End of the loop over the mcnesp points
c
      enddo
c
c
      return
      end
c***********************************************************************
c     mctesis
c***********************************************************************
c
      subroutine mctesis(redun)
c
c     This subroutine is analogous to mctesi. It calculates the D, b, and C
c     coefficients for each symmetrically equivalent Shepard point.
c     (O.T. October 2006)
c
      implicit double precision (a-h,o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      parameter (zero   = 0.0d0 )  
      parameter (mcmca2=mcmcar*(mcmcar+1)/2)
      parameter (mcmic2=mcmics*(mcmics+1)/2)
c
      dimension x0(mcmcar)                  
      dimension x0_12(mcmcar)                                           
      dimension x0_23(mcmcar)                                           
      dimension x0_13(mcmcar)                                           
      dimension x0_123(mcmcar)                                          
      dimension x0_132(mcmcar)                                          
      dimension d0(mcmcar),d1(mcmcar),d2(mcmcar)                        
      dimension d0_E(mcmcar),d1_E(mcmcar),d2_E(mcmcar)                  
      dimension d0_12(mcmcar),d1_12(mcmcar),d2_12(mcmcar)               
      dimension d0_23(mcmcar),d1_23(mcmcar),d2_23(mcmcar)               
      dimension d0_13(mcmcar),d1_13(mcmcar),d2_13(mcmcar)                
      dimension d0_123(mcmcar),d1_123(mcmcar),d2_123(mcmcar)            
      dimension d0_132(mcmcar),d1_132(mcmcar),d2_132(mcmcar)            
      dimension d1tmp(mcmcar),d2tmp(mcmcar)                             
      dimension d1av12(mcmcar),d2av12(mcmcar)                           
      dimension d1av23(mcmcar),d2av23(mcmcar)                           
      dimension d1av13(mcmcar),d2av13(mcmcar)                           
      dimension d1av123(mcmcar),d2av123(mcmcar)                         
      dimension d1av132(mcmcar),d2av132(mcmcar)                         
      dimension dxint0(mcmics),dxint1(mcmics),dxint2(mcmics)            
      dimension dxint0_12(mcmics),dxint1_12(mcmics),dxint2_12(mcmics)   
      dimension dxint0_23(mcmics),dxint1_23(mcmics),dxint2_23(mcmics)   
      dimension dxint0_13(mcmics),dxint1_13(mcmics),dxint2_13(mcmics)   
      dimension dxint0_123(mcmics),dxint1_123(mcmics),dxint2_123(mcmics)
      dimension dxint0_132(mcmics),dxint1_132(mcmics),dxint2_132(mcmics)
      dimension dxint1avE(mcmics)                                       
      dimension dxint1av12(mcmics),dxint1av23(mcmics),dxint1av13(mcmics)
      dimension dxint1av123(mcmics), dxint1av132(mcmics)                
      dimension dxint2av12(mcmics),dxint2av23(mcmics)                   
      dimension dxint2avE(mcmics)                                       
      dimension dxint2av13(mcmics),dxint2av123(mcmics)                  
      dimension dxint2av132(mcmics)                                     
c
      double precision k0(mcmcar,mcmcar),
     *                 k0_12(mcmcar,mcmcar),                            
     *                 k0_23(mcmcar,mcmcar),                            
     *                 k0_13(mcmcar,mcmcar),                            
     *                 k0_123(mcmcar,mcmcar),                           
     *                 k0_132(mcmcar,mcmcar),                           
     *                 k1(mcmcar,mcmcar),
     *                 k1_E(mcmcar,mcmcar),                             
     *                 k1_12(mcmcar,mcmcar),                            
     *                 k1_23(mcmcar,mcmcar),                            
     *                 k1_13(mcmcar,mcmcar),                            
     *                 k1_123(mcmcar,mcmcar),                           
     *                 k1_132(mcmcar,mcmcar),                           
     *                 k1av12(mcmcar,mcmcar),                           
     *                 k1av23(mcmcar,mcmcar),                           
     *                 k1av13(mcmcar,mcmcar),                           
     *                 k1av123(mcmcar,mcmcar),                          
     *                 k1av132(mcmcar,mcmcar),                          
     *                 k2(mcmcar,mcmcar),
     *                 k2_E(mcmcar,mcmcar),                             
     *                 k2_12(mcmcar,mcmcar),                            
     *                 k2_23(mcmcar,mcmcar),                            
     *                 k2_13(mcmcar,mcmcar),                            
     *                 k2_123(mcmcar,mcmcar),                           
     *                 k2_132(mcmcar,mcmcar)                            
      double precision kxint0(mcmics,mcmics),
     *                 kxint0_12(mcmics,mcmics),                        
     *                 kxint0_23(mcmics,mcmics),                        
     *                 kxint0_13(mcmics,mcmics),                        
     *                 kxint0_123(mcmics,mcmics),                       
     *                 kxint0_132(mcmics,mcmics),                       
     *                 kxint1(mcmics,mcmics),
     *                 kxint1_12(mcmics,mcmics),                        
     *                 kxint1_23(mcmics,mcmics),                        
     *                 kxint1_13(mcmics,mcmics),                        
     *                 kxint1_123(mcmics,mcmics),                       
     *                 kxint1_132(mcmics,mcmics),                       
     *                 kxint2(mcmics,mcmics),
     *                 kxint2_12(mcmics,mcmics),                        
     *                 kxint2_23(mcmics,mcmics),                        
     *                 kxint2_13(mcmics,mcmics),                        
     *                 kxint2_123(mcmics,mcmics),                       
     *                 kxint2_132(mcmics,mcmics),                       
     *                 k2av12(mcmcar,mcmcar),                           
     *                 k2av23(mcmcar,mcmcar),                           
     *                 k2av13(mcmcar,mcmcar),                           
     *                 k2av123(mcmcar,mcmcar),                          
     *                 k2av132(mcmcar,mcmcar),                          
     *                 xlooker1(mcmcar,mcmcar),                         
     *                 xlooker2(mcmcar,mcmcar),                         
     *                 xlooker3(mcmcar,mcmcar),                         
     *                 xlooker3a(mcmcar,mcmcar),                        
     *                 xlooker4(mcmcar,mcmcar),                         
     *                 xlooker5(mcmcar,mcmcar),                         
     *                 k1avE(mcmcar,mcmcar),                            
     *                 k0_12t(mcmcar,mcmcar)                            
c
      dimension dics(mcmics)
      dimension dics_12(mcmics)                                         
      dimension dics_23(mcmics)                                         
      dimension dics_13(mcmics)                                         
      dimension dics_123(mcmics)                                        
      dimension dics_132(mcmics)                                        
      dimension dicd(mcmicd)
      dimension dicd_12(mcmicd)                                         
      dimension dicd_23(mcmicd)                                         
      dimension dicd_13(mcmicd)                                         
      dimension dicd_123(mcmicd)                                        
      dimension dicd_132(mcmicd)                                        
      dimension xc(mcmatm),yc(mcmatm),zc(mcmatm)
      dimension xc_12(mcmatm),yc_12(mcmatm),zc_12(mcmatm)               
      dimension xc_23(mcmatm),yc_23(mcmatm),zc_23(mcmatm)               
      dimension xc_13(mcmatm),yc_13(mcmatm),zc_13(mcmatm)               
      dimension xc_123(mcmatm),yc_123(mcmatm),zc_123(mcmatm)            
      dimension xc_132(mcmatm),yc_132(mcmatm),zc_132(mcmatm)            
      dimension amatb(mcmics,mcmcar)
      dimension amatb_12(mcmics,mcmcar)                                 
      dimension amatb_23(mcmics,mcmcar)                                 
      dimension amatb_13(mcmics,mcmcar)                                 
      dimension amatb_123(mcmics,mcmcar)                                
      dimension amatb_132(mcmics,mcmcar)                                
      dimension amatbi(mcmcar,mcmics)
      dimension amatbi_12(mcmcar,mcmics)                                
      dimension amatbi_23(mcmcar,mcmics)                                
      dimension amatbi_13(mcmcar,mcmics)                                
      dimension amatbi_123(mcmcar,mcmics)                               
      dimension amatbi_132(mcmcar,mcmics)                               
      dimension amatbt(mcmics,mcmic2)
      dimension amatbt_12(mcmics,mcmic2)                                
      dimension amatbt_23(mcmics,mcmic2)                                
      dimension amatbt_13(mcmics,mcmic2)                                
      dimension amatbt_123(mcmics,mcmic2)                               
      dimension amatbt_132(mcmics,mcmic2)                               
      dimension amatc(mcmic2)
      dimension amatc_12(mcmic2)                                        
      dimension amatc_23(mcmic2)                                        
      dimension amatc_13(mcmic2)                                        
      dimension amatc_123(mcmic2)                                       
      dimension amatc_132(mcmic2)                                       
      dimension egnm(mcmics,mcmics) 
      dimension egnm_12(mcmics,mcmics)                                  
      dimension egnm_23(mcmics,mcmics)                                  
      dimension egnm_13(mcmics,mcmics)                                  
      dimension egnm_123(mcmics,mcmics)                                 
      dimension egnm_132(mcmics,mcmics)                                 
      dimension ggi(mcmics,mcmics)
      dimension ggi_12(mcmics,mcmics)                                   
      dimension ggi_23(mcmics,mcmics)                                   
      dimension ggi_13(mcmics,mcmics)                                   
      dimension ggi_123(mcmics,mcmics)                                  
      dimension ggi_132(mcmics,mcmics)                                  
      dimension gm(mcmics,mcmics)
      dimension amasin(mcmcar,mcmcar)
      dimension amasin_12(mcmcar,mcmcar)                                
      dimension amasin_23(mcmcar,mcmcar)                                
      dimension amasin_13(mcmcar,mcmcar)                                
      dimension amasin_123(mcmcar,mcmcar)                               
      dimension amasin_132(mcmcar,mcmcar)                               
      dimension flgm(mcmics)
      dimension scr(mcmcar,mcmics)
      dimension scr_12(mcmcar,mcmics)                                   
      dimension scr_23(mcmcar,mcmics)                                   
      dimension scr_13(mcmcar,mcmics)                                   
      dimension scr_123(mcmcar,mcmics)                                  
      dimension scr_132(mcmcar,mcmics)                                  
      dimension scr3(mcmic2)
      dimension scr3_12(mcmic2)                                         
      dimension scr3_23(mcmic2)                                         
      dimension scr3_13(mcmic2)                                         
      dimension scr3_123(mcmic2)                                        
      dimension scr3_132(mcmic2)                                        
      dimension fl(mcmca2)
      dimension fl_12(mcmca2)                                           
      dimension fl_23(mcmca2)                                           
      dimension fl_13(mcmca2)                                           
      dimension fl_123(mcmca2)                                          
      dimension fl_132(mcmca2)                                          
c
      logical redun
c
c     Define some variables
c
      mcncar = 3*mcnatm
c
c initialization                                                        
        v1=zero                                                         
        v2=zero                                                         
        v1_E=zero                                                       
        v1_12=zero                                                      
        v1_23=zero                                                      
        v1_13=zero                                                      
        v1_123=zero                                                     
        v1_132=zero                                                     
        v2_E=zero                                                       
        v2_12=zero                                                      
        v2_23=zero                                                      
        v2_13=zero                                                      
        v2_123=zero                                                     
        v2_132=zero                                                     
        expsum=zero                                                     
        expsum_2=zero                                                   
        do i=1,mcmics
            dxint0(i)=zero
            dxint0_12(i)=zero                                           
            dxint0_23(i)=zero                                           
            dxint0_13(i)=zero                                           
            dxint0_123(i)=zero                                          
            dxint0_132(i)=zero                                          
            dxint1(i)=zero
            dxint1_12(i)=zero                                           
            dxint1_23(i)=zero                                           
            dxint1_13(i)=zero                                           
            dxint1_123(i)=zero                                          
            dxint1_132(i)=zero                                          
            dxint2(i)=zero
            dxint2_12(i)=zero                                           
            dxint2_23(i)=zero                                           
            dxint2_13(i)=zero                                           
            dxint2_123(i)=zero                                          
            dxint2_132(i)=zero                                          
            dxint1avE(i)=zero                                           
            dxint1av12(i)=zero                                          
            dxint1av23(i)=zero                                          
            dxint1av13(i)=zero                                          
            dxint1av123(i)=zero                                         
            dxint1av132(i)=zero                                         
            dxint2avE(i)=zero                                           
            dxint2av12(i)=zero                                           
            dxint2av23(i)=zero                                          
            dxint2av13(i)=zero                                          
            dxint2av123(i)=zero                                         
            dxint2av132(i)=zero                                         
             do j=1,mcmics
               kxint0(i,j)=zero
               kxint0_12(i,j)=zero                                   
               kxint0_23(i,j)=zero                                   
               kxint0_13(i,j)=zero                                   
               kxint0_123(i,j)=zero                                  
               kxint0_132(i,j)=zero                                  
             enddo
             do j=1,mcmics
               kxint1(i,j)=zero
               kxint1_12(i,j)=zero                                   
               kxint1_23(i,j)=zero                                   
               kxint1_13(i,j)=zero                                   
               kxint1_123(i,j)=zero                                  
               kxint1_132(i,j)=zero                                  
             enddo 
             do j=1,mcmics
               kxint2(i,j)=zero
               kxint2_12(i,j)=zero                                   
               kxint2_23(i,j)=zero                                   
               kxint2_13(i,j)=zero                                   
               kxint2_123(i,j)=zero                                  
               kxint2_132(i,j)=zero                                  
             enddo
        enddo 
        do ih=1,mcmcar                                                
          x0(ih)=zero                                                 
          x0_12(ih)=zero                                              
          x0_23(ih)=zero                                              
          x0_13(ih)=zero                                              
          x0_123(ih)=zero                                             
          x0_132(ih)=zero                                             
          d0(ih)=zero                                                 
          d0_12(ih)=zero                                              
          d0_23(ih)=zero                                              
          d0_13(ih)=zero                                              
          d0_123(ih)=zero                                             
          d0_132(ih)=zero                                             
          d1(ih)=zero                                                 
          d1_E(ih)=zero                                               
          d1_12(ih)=zero                                              
          d1_23(ih)=zero                                              
          d1_13(ih)=zero                                              
          d1_123(ih)=zero                                             
          d1_132(ih)=zero                                             
          d1tmp(ih)=zero                                              
          d1av12(ih)=zero                                             
          d1av23(ih)=zero                                             
          d1av13(ih)=zero                                             
          d1av123(ih)=zero                                            
          d1av132(ih)=zero                                            
          d2av12(ih)=zero                                             
          d2av23(ih)=zero                                             
          d2av13(ih)=zero                                             
          d2av123(ih)=zero                                            
          d2av132(ih)=zero                                            
          d2(ih)=zero                                                 
          d2_E(ih)=zero                                               
          d2_12(ih)=zero                                              
          d2_23(ih)=zero                                              
          d2_13(ih)=zero                                              
          d2_123(ih)=zero                                             
          d2_132(ih)=zero                                             
          do jh=1,mcmcar                                              
            k0(ih,jh)=zero                                          
            k0_12(ih,jh)=zero                                       
            k0_23(ih,jh)=zero                                       
            k0_13(ih,jh)=zero                                       
            k0_123(ih,jh)=zero                                       
            k0_132(ih,jh)=zero                                      
            k1(ih,jh)=zero                                          
            k1_E(ih,jh)=zero                                        
            k1_12(ih,jh)=zero                                       
            k1_23(ih,jh)=zero                                       
            k1_13(ih,jh)=zero                                       
            k1_123(ih,jh)=zero                                      
            k1_132(ih,jh)=zero                                      
            k1avE(ih,jh)=zero                                       
            k1av12(ih,jh)=zero                                      
            k1av23(ih,jh)=zero                                      
            k1av13(ih,jh)=zero                                      
            k1av123(ih,jh)=zero                                      
            k1av132(ih,jh)=zero                                     
            k2(ih,jh)=zero                                          
            k2_E(ih,jh)=zero                                        
            k2_12(ih,jh)=zero                                       
            k2_23(ih,jh)=zero                                       
            k2_13(ih,jh)=zero                                       
            k2_123(ih,jh)=zero                                      
            k2_132(ih,jh)=zero                                      
            k2av12(ih,jh)=zero                                      
            k2av23(ih,jh)=zero                                      
            k2av13(ih,jh)=zero                                      
            k2av123(ih,jh)=zero                                     
            k2av132(ih,jh)=zero                                     
            xlooker1(ih,jh)=zero                                    
            xlooker2(ih,jh)=zero                                    
            xlooker3(ih,jh)=zero                                    
            xlooker3a(ih,jh)=zero                                   
            xlooker4(ih,jh)=zero                                    
            xlooker5(ih,jh)=zero                                    
            k0_12t(ih,jh)=zero                                      
          enddo                                                         
        enddo                                                           
c
c     Start a loop over the mcnesp (electronic structure theory Shepard points)
c
      do mciesp=1,mcnesp
c
c     Put the Shepard point information into the working arrays
c
         v0=vsh(mciesp)
         do i=1,mcncar
            x0(i)=xsh(i,mciesp)
            d0(i)=dsh(i,mciesp)
            do j=1,mcncar
               k0(i,j)=hsh(i,j,mciesp)
            enddo
         enddo
c Permutation of rows in arrays with Shepard point geom and grad        
          call mc12perm(x0_12,x0)                                       
          call mc12perm(d0_12,d0)                                       
          call mc23perm(x0_23,x0)                                        
          call mc23perm(d0_23,d0)                                       
          call mc13perm(x0_13,x0)                                       
          call mc13perm(d0_13,d0)                                       
          call mc123perm(x0_123,x0)                                     
          call mc123perm(d0_123,d0)                                     
          call mc132perm(x0_132,x0)                                     
          call mc132perm(d0_132,d0)                                     
c Permutation of rows and columns in Hessian matrices at Shepard points
          call mc12perm2(k0_12,k0)                                   
          call mc23perm2(k0_23,k0)                                   
          call mc13perm2(k0_13,k0)                                   
          call mc13perm2(k0_12t,k0)                                  
          call mc23perm2(k0_123,k0_12t)                              
          do i=1,mcncar                                                 
          do j=1,mcncar                                                 
           k0_12t(i,j)=0.d0                                             
           enddo                                                        
           enddo                                                        
          call mc12perm2(k0_12t,k0)                                  
          call mc23perm2(k0_132,k0_12t)                              
          do i=1,mcncar                                                 
          do j=1,mcncar                                                 
           k0_12t(i,j)=0.d0                                             
           enddo                                                        
           enddo                                                        
c
c     Calculate v1, d1 and k1 by means of a mcviic call.
cOT  These are now calculated n!=6 times for each permutation.          
c
         call mcviic(x0,v1_E,d1_E,k1_E,3,1,1)                             
         call mcviic(x0_12,v1_12,d1_12,k1_12,3,1,1)                         
         call mcviic(x0_23,v1_23,d1_23,k1_23,3,1,1)                         
         call mcviic(x0_13,v1_13,d1_13,k1_13,3,1,1)                         
         call mcviic(x0_123,v1_123,d1_123,k1_123,3,1,1)                     
         call mcviic(x0_132,v1_132,d1_132,k1_132,3,1,1)                     
c
         exxp1 = dexp(-alphaV1*v1_E)                                    
         exxp2 = dexp(-alphaV1*v1_12)                                   
         exxp3 = dexp(-alphaV1*v1_23)                                   
         exxp4 = dexp(-alphaV1*v1_13)                                   
         exxp5 = dexp(-alphaV1*v1_123)                                  
         exxp6 = dexp(-alphaV1*v1_132)                                  
c
         v1=-(1.d0/alphaV1)*dlog(1.d0/isigmav1*(exxp1+exxp2             
     *   +exxp3+exxp4+exxp5+exxp6))                                     
c
         expsum=exxp1+exxp2+exxp3+exxp4+exxp5+exxp6                     
c
c Symmetrized gradient (\tilde{G})
         do i=1,12                                                      
          d1tmp(i)=exxp1*d1_E(i)+exxp2*d1_12(i)+exxp3*d1_23(i)          
     *    +exxp4*d1_13(i)+exxp5*d1_123(i)+exxp6*d1_132(i)               
           d1(i)=d1tmp(i)/expsum                                        
         enddo                                                          
c
          call mc12perm (d1av12,d1)                                     
          call mc23perm (d1av23,d1)                                     
          call mc13perm (d1av13,d1)                                     
          call mc123perm (d1av123,d1)                                   
          call mc132perm (d1av132,d1)                                   
c
         do i=1,mcncar                                                  
           do j=1,mcncar                                                
         xlooker1(i,j)=(k1_E(i,j)-alphaV1*d1_E(i)*d1_E(j))*exxp1+       
     *   (k1_12(i,j)-alphaV1*d1_12(i)*d1_12(j))*exxp2+                  
     *   (k1_23(i,j)-alphaV1*d1_23(i)*d1_23(j))*exxp3+                  
     *   (k1_13(i,j)-alphaV1*d1_13(i)*d1_13(j))*exxp4+                  
     * (k1_123(i,j)-alphaV1*d1_123(i)*d1_123(j))*exxp5+                 
     * (k1_132(i,j)-alphaV1*d1_132(i)*d1_132(j))*exxp6                  
            xlooker2(i,j)=xlooker1(i,j)/expsum                          
            xlooker3(i,j)=d1_E(i)*exxp1+                                
     *     d1_12(i)*exxp2+                                              
     *     d1_23(i)*exxp3+                                              
     *     d1_13(i)*exxp4+                                              
     *     d1_123(i)*exxp5+                                             
     *     d1_132(i)*exxp6                                              
           xlooker3a(i,j)=d1_E(j)*exxp1+                                
     *     d1_12(j)*exxp2+                                              
     *     d1_23(j)*exxp3+                                              
     *     d1_13(j)*exxp4+                                              
     *     d1_123(j)*exxp5+                                             
     *     d1_132(j)*exxp6                                              
           xlooker4(i,j)=alphaV1*xlooker3(i,j)*                         
     *     xlooker3a(i,j)/(expsum**2)                                   
           xlooker5(i,j)=xlooker2(i,j)+xlooker4(i,j)                    
           enddo                                                        
         enddo                                                          
           do i=1,mcncar                                                
           do j=1,mcncar                                                
           k1avE(i,j)=xlooker5(i,j)                                     
           enddo                                                        
         enddo                                                          
          call mc12perm2(k1av12,k1avE)                               
          call mc23perm2(k1av23,k1avE)                               
          call mc13perm2(k1av13,k1avE)                               
          do i=1,mcncar                                                 
          do j=1,mcncar                                                 
           k0_12t(i,j)=0.d0                                             
           enddo                                                        
           enddo                                                        
          call mc13perm2(k0_12t,k1avE)                               
          call mc23perm2(k1av123,k0_12t)                             
          do i=1,mcncar                                                 
          do j=1,mcncar                                                 
           k0_12t(i,j)=0.d0                                             
           enddo                                                        
           enddo                                                        
          call mc12perm2(k0_12t,k1avE)                               
          call mc23perm2(k1av132,k0_12t)                             
c          
c
c     And now, the same for v2, d2, and k2:
c
         expsum=0.d0                                                    
         expsum_2=0.d0                                                  
         call mcviic(x0,v2_E,d2_E,k2_E,3,2,1)                             
         call mcviic(x0_12,v2_12,d2_12,k2_12,3,2,1)                         
         call mcviic(x0_23,v2_23,d2_23,k2_23,3,2,1)                         
         call mcviic(x0_13,v2_13,d2_13,k2_13,3,2,1)                         
         call mcviic(x0_123,v2_123,d2_123,k2_123,3,2,1)                     
         call mcviic(x0_132,v2_132,d2_132,k2_132,3,2,1)                     
         exxp1_2 = dexp(-alphaV2*v2_E)                                  
         exxp2_2 = dexp(-alphaV2*v2_12)                                 
         exxp3_2= dexp(-alphaV2*v2_23)                                  
         exxp4_2= dexp(-alphaV2*v2_13)                                  
         exxp5_2= dexp(-alphaV2*v2_123)                                 
         exxp6_2= dexp(-alphaV2*v2_132)                                 
         v2=-(1.d0/alphaV2)*dlog(1.d0/isigmav2*(exxp1_2+exxp2_2+         
     *   exxp3_2+exxp4_2+exxp5_2+exxp6_2))                              
c
         expsum_2=exxp1_2+exxp2_2+exxp3_2+exxp4_2+exxp5+exxp6_2         
c
c Symmetrized gradient (\tilde{G_2})
         do i=1,12                                                      
          d2tmp(i)=exxp1_2*d2_E(i)+exxp2_2*d2_12(i)+exxp3_2*d2_23(i)    
     *    +exxp4_2*d2_13(i)+exxp5_2*d2_123(i)+exxp6_2*d2_132(i)         
           d2(i)=d2tmp(i)/expsum_2                                      
         enddo                                                          
c
c   d2_av_12(i) is the gradient at the "reflected" (k)-point            
          call mc12perm (d2av12,d2)                                     
          call mc23perm (d2av23,d2)                                     
          call mc13perm (d2av13,d2)                                     
          call mc123perm (d2av123,d2)                                   
          call mc132perm (d2av132,d2)                                   
c         
         do i=1,mcmcar                                                  
         do j=1,mcmcar                                                  
         xlooker1(i,j)=0.d0                                             
         xlooker2(i,j)=0.d0                                             
         xlooker3(i,j)=0.d0                                             
         xlooker3a(i,j)=0.d0                                            
         xlooker4(i,j)=0.d0                                             
         xlooker5(i,j)=0.d0                                             
        enddo                                                           
         enddo                                                          
         do i=1,mcncar                                                  
           do j=1,mcncar                                                
         xlooker1(i,j)=(k2_E(i,j)-alphaV2*d2_E(i)*d2_E(j))*exxp1_2+     
     *   (k2_12(i,j)-alphaV2*d2_12(i)*d2_12(j))*exxp2_2+                
     *   (k2_23(i,j)-alphaV2*d2_23(i)*d2_23(j))*exxp3_2+                
     *   (k2_13(i,j)-alphaV2*d2_13(i)*d2_13(j))*exxp4_2+                
     * (k2_123(i,j)-alphaV2*d2_123(i)*d2_123(j))*exxp5_2+               
     * (k2_132(i,j)-alphaV2*d2_132(i)*d2_132(j))*exxp6_2                
            xlooker2(i,j)=xlooker1(i,j)/expsum_2                        
            xlooker3(i,j)=d2_E(i)*exxp1_2+                              
     *     d2_12(i)*exxp2_2+                                            
     *     d2_23(i)*exxp3_2+                                            
     *     d2_13(i)*exxp4_2+                                            
     *     d2_123(i)*exxp5_2+                                           
     *     d2_132(i)*exxp6_2                                            
           xlooker3a(i,j)=d2_E(j)*exxp1_2+                              
     *     d2_12(j)*exxp2_2+                                            
     *     d2_23(j)*exxp3_2+                                            
     *     d2_13(j)*exxp4_2+                                            
     *     d2_123(j)*exxp5_2+                                           
     *     d2_132(j)*exxp6_2                                            
           xlooker4(i,j)=alphaV2*xlooker3(i,j)*                         
     *     xlooker3a(i,j)/(expsum_2**2)                                 
           xlooker5(i,j)=xlooker2(i,j)+xlooker4(i,j)                     
           enddo                                                        
         enddo                                                          
           do i=1,mcncar                                                
           do j=1,mcncar                                                
           k2(i,j)=xlooker5(i,j)                                        
           enddo                                                        
         enddo                                                          
          call mc12perm2(k2av12,k2)                                  
          call mc23perm2(k2av23,k2)                                  
          call mc13perm2(k2av13,k2)                                  
          do i=1,mcncar                                                 
          do j=1,mcncar                                                 
           k0_12t(i,j)=0.d0                                             
          enddo                                                         
          enddo                                                         
          call mc13perm2(k0_12t,k2)                                  
          call mc23perm2(k2av123,k0_12t)                             
          do i=1,mcncar                                                 
          do j=1,mcncar                                                 
           k0_12t(i,j)=0.d0                                             
          enddo                                                         
          enddo                                                         
          call mc12perm2(k0_12t,k2)                                  
          call mc23perm2(k2av132,k0_12t)                             
          do i=1,mcncar                                                 
          do j=1,mcncar                                                 
           k0_12t(i,j)=0.d0                                             
          enddo                                                         
          enddo                                                         
c
c     Rearrange the Cartesian coordinates:
c
         do j = 1, mcnatm
            xc(j) = x0(3*j-2)
            yc(j) = x0(3*j-1)
            zc(j) = x0(3*j)
            xc_12(j) = x0_12(3*j-2)                                     
            yc_12(j) = x0_12(3*j-1)                                     
            zc_12(j) = x0_12(3*j)                                       
            xc_23(j) = x0_23(3*j-2)                                     
            yc_23(j) = x0_23(3*j-1)                                     
            zc_23(j) = x0_23(3*j)                                       
            xc_13(j) = x0_13(3*j-2)                                          
            yc_13(j) = x0_13(3*j-1)                                     
            zc_13(j) = x0_13(3*j)                                        
            xc_123(j) = x0_123(3*j-2)                                   
            yc_123(j) = x0_123(3*j-1)                                   
            zc_123(j) = x0_123(3*j)                                     
            xc_132(j) = x0_132(3*j-2)                                   
            yc_132(j) = x0_132(3*j-1)                                   
            zc_132(j) = x0_132(3*j)                                     
         end do
c
c     Transform the cartesian coordinates of the electronic structure
c     theory Shepard points nto 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)
         call mctcic(mcndid,mcnand,mcnadd,mcndad,                       
     *               mcidid,mciand,mciadd,mcidad,                       
     *         mcmicd,mcmatm,xc_12,yc_12,zc_12,dicd_12)                 
         call mctcic(mcndid,mcnand,mcnadd,mcndad,                       
     *               mcidid,mciand,mciadd,mcidad,                       
     *         mcmicd,mcmatm,xc_23,yc_23,zc_23,dicd_23)                 
         call mctcic(mcndid,mcnand,mcnadd,mcndad,                       
     *               mcidid,mciand,mciadd,mcidad,                       
     *         mcmicd,mcmatm,xc_13,yc_13,zc_13,dicd_13)                 
         call mctcic(mcndid,mcnand,mcnadd,mcndad,                       
     *               mcidid,mciand,mciadd,mcidad,                       
     *         mcmicd,mcmatm,xc_123,yc_123,zc_123,dicd_123)             
         call mctcic(mcndid,mcnand,mcnadd,mcndad,                       
     *               mcidid,mciand,mciadd,mcidad,                       
     *         mcmicd,mcmatm,xc_132,yc_132,zc_132,dicd_132)             
         do i = 1, mcnicd
            qd0(i,mciesp) = dicd(i)
            qd0_12(i,mciesp) = dicd_12(i)                               
            qd0_23(i,mciesp) = dicd_23(i)                               
            qd0_13(i,mciesp) = dicd_13(i)                               
            qd0_123(i,mciesp) = dicd_123(i)                             
            qd0_132(i,mciesp) = dicd_132(i)                             
         end do
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)
         call mctcic(mcndis,mcnans,mcnads,mcndas,                       
     *               mcidis,mcians,mciads,mcidas,                       
     *          mcmics,mcmatm,xc_12,yc_12,zc_12,dics_12)                
         call mctcic(mcndis,mcnans,mcnads,mcndas,                       
     *               mcidis,mcians,mciads,mcidas,                       
     *          mcmics,mcmatm,xc_23,yc_23,zc_23,dics_23)                
         call mctcic(mcndis,mcnans,mcnads,mcndas,                       
     *               mcidis,mcians,mciads,mcidas,                       
     *          mcmics,mcmatm,xc_13,yc_13,zc_13,dics_13)                
         call mctcic(mcndis,mcnans,mcnads,mcndas,                       
     *               mcidis,mcians,mciads,mcidas,                       
     *      mcmics,mcmatm,xc_123,yc_123,zc_123,dics_123)                
         call mctcic(mcndis,mcnans,mcnads,mcndas,                       
     *               mcidis,mcians,mciads,mcidas,                       
     *      mcmics,mcmatm,xc_132,yc_132,zc_132,dics_132)                
         do i = 1, mcnics
            qs0(i,mciesp) = dics(i)
            qs0_12(i,mciesp) = dics_12(i)                               
            qs0_23(i,mciesp) = dics_23(i)                               
            qs0_13(i,mciesp) = dics_13(i)                               
            qs0_123(i,mciesp) = dics_123(i)                             
            qs0_132(i,mciesp) = dics_132(i)                             
         end do
         call mcybmat (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,
     *                 mcidas,mciads,xc,yc,zc,mcnatm,mcnics,
     *                 amatb,t,mcmatm,mcmics,mcmcar)
         call mcybmat (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,       
     *             mcidas,mciads,xc_12,yc_12,zc_12,mcnatm,mcnics,       
     *                 amatb_12,t,mcmatm,mcmics,mcmcar)                 
         call mcybmat (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,       
     *             mcidas,mciads,xc_23,yc_23,zc_23,mcnatm,mcnics,       
     *                 amatb_23,t,mcmatm,mcmics,mcmcar)                 
         call mcybmat (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,       
     *             mcidas,mciads,xc_13,yc_13,zc_13,mcnatm,mcnics,       
     *                 amatb_13,t,mcmatm,mcmics,mcmcar)                 
         call mcybmat (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,       
     *             mcidas,mciads,xc_123,yc_123,zc_123,mcnatm,mcnics,    
     *                 amatb_123,t,mcmatm,mcmics,mcmcar)                
         call mcybmat (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,       
     *             mcidas,mciads,xc_132,yc_132,zc_132,mcnatm,mcnics,    
     *                 amatb_132,t,mcmatm,mcmics,mcmcar)                
c
c  2) compute the A matrix
cOT 
c         redun=.true.
c
         if (redun) then
            call mcybimat2 (amatb,amatbi,cmmc,amasin,gm,ggi,flgm,
     *                      egnm,smmc,mcnatm,mcnics,mcmics,mcmcar)
            call mcybimat2 (amatb_12,amatbi_12,cmmc,amasin,gm,          
     *                      ggi,flgm,                                   
     *                      egnm,smmc,mcnatm,mcnics,mcmics,mcmcar)      
            call mcybimat2 (amatb_23,amatbi_23,cmmc,amasin,gm,          
     *                      ggi,flgm,                                   
     *                      egnm,smmc,mcnatm,mcnics,mcmics,mcmcar)      
            call mcybimat2 (amatb_13,amatbi_13,cmmc,amasin,gm,          
     *                      ggi,flgm,                                   
     *                      egnm,smmc,mcnatm,mcnics,mcmics,mcmcar)      
        call mcybimat2 (amatb_123,amatbi_123,cmmc,amasin,gm,            
     *                      ggi,flgm,                                   
     *                      egnm,smmc,mcnatm,mcnics,mcmics,mcmcar)      
        call mcybimat2 (amatb_132,amatbi_132,cmmc,amasin,gm,            
     *                      ggi,flgm,                                   
     *                      egnm,smmc,mcnatm,mcnics,mcmics,mcmcar)      
         else
            call mcybimat (amatb,amatbi,cmmc,amasin,gm,smmc,
     *                     mcnatm,mcnics,mcmics,mcmcar)
            call mcybimat (amatb_12,amatbi_12,cmmc,amasin,gm,smmc,      
     *                     mcnatm,mcnics,mcmics,mcmcar)                 
            call mcybimat (amatb_23,amatbi_23,cmmc,amasin,gm,smmc,      
     *                     mcnatm,mcnics,mcmics,mcmcar)                 
            call mcybimat (amatb_13,amatbi_13,cmmc,amasin,gm,smmc,      
     *                     mcnatm,mcnics,mcmics,mcmcar)                 
        call mcybimat (amatb_123,amatbi_123,cmmc,amasin,gm,smmc,        
     *                     mcnatm,mcnics,mcmics,mcmcar)                 
        call mcybimat (amatb_132,amatbi_132,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 (dxint0_12,amatbi_12,d0_12,mcnics,mcncar,mcmics,   
     *                mcmcar)                                           
         call trangj (dxint0_23,amatbi_23,d0_23,mcnics,mcncar,mcmics,   
     *                mcmcar)                                           
         call trangj (dxint0_13,amatbi_13,d0_13,mcnics,mcncar,mcmics,   
     *                mcmcar)                                           
         call trangj (dxint0_123,amatbi_123,d0_123,mcnics,mcncar,mcmics,
     *                mcmcar)                                           
         call trangj (dxint0_132,amatbi_132,d0_132,mcnics,mcncar,mcmics,
     *                mcmcar)                                           
c
        call trangj (dxint1avE,amatbi,d1,mcnics,mcncar,mcmics,mcmcar)   
        call trangj (dxint1av12,amatbi_12,d1av12,mcnics,mcncar,         
     *              mcmics,mcmcar)                                      
        call trangj (dxint1av23,amatbi_23,d1av23,mcnics,mcncar,         
     *              mcmics,mcmcar)                                      
        call trangj (dxint1av13,amatbi_13,d1av13,mcnics,mcncar,         
     *              mcmics,mcmcar)                                      
        call trangj (dxint1av123,amatbi_123,d1av123,mcnics,mcncar,      
     *              mcmics,mcmcar)                                      
        call trangj (dxint1av132,amatbi_132,d1av132,mcnics,mcncar,      
     *              mcmics,mcmcar)                                      
        call trangj (dxint2avE,amatbi,d2,mcnics,mcncar,mcmics,mcmcar)   
        call trangj (dxint2av12,amatbi_12,d2av12,mcnics,mcncar,         
     *              mcmics,mcmcar)                                      
        call trangj (dxint2av23,amatbi_23,d2av23,mcnics,mcncar,         
     *              mcmics,mcmcar)                                      
        call trangj (dxint2av13,amatbi_13,d2av13,mcnics,mcncar,         
     *              mcmics,mcmcar)                                      
        call trangj (dxint2av123,amatbi_123,d2av123,mcnics,mcncar,      
     *              mcmics,mcmcar)                                      
        call trangj (dxint2av132,amatbi_132,d2av132,mcnics,mcncar,      
     *              mcmics,mcmcar)                                      
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 i = 1, mcmic2
            do j=1, mcmics
               amatbt(j,i) = zero
            enddo
         end do
         call ybtens (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,
     *                mcidas,mciads,xc,yc,zc,mcnatm,amatbi,
     *                amatbt,mcnics,mcncar,mcmics,mcmic2,mcmatm,t)
c
         do i = 1, mcmic2                                               
            do j=1, mcmics                                              
               amatbt_12(j,i) = zero                                    
            enddo                                                       
         end do                                                         
         call ybtens (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,        
     *              mcidas,mciads,xc_12,yc_12,zc_12,mcnatm,amatbi_12,   
     *              amatbt_12,mcnics,mcncar,mcmics,mcmic2,mcmatm,t_12)  
c         
         do i = 1, mcmic2                                               
            do j=1, mcmics                                              
               amatbt_23(j,i) = zero                                    
            enddo                                                       
         end do                                                         
         call ybtens (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,        
     *              mcidas,mciads,xc_23,yc_23,zc_23,mcnatm,amatbi_23,   
     *              amatbt_23,mcnics,mcncar,mcmics,mcmic2,mcmatm,t_23)  
c         
         do i = 1, mcmic2                                               
            do j=1, mcmics                                              
               amatbt_13(j,i) = zero                                    
            enddo                                                       
         end do                                                         
         call ybtens (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,        
     *              mcidas,mciads,xc_13,yc_13,zc_13,mcnatm,amatbi_13,   
     *              amatbt_13,mcnics,mcncar,mcmics,mcmic2,mcmatm,t_13)  
c         
         do i = 1, mcmic2                                               
            do j=1, mcmics                                              
               amatbt_123(j,i) = zero                                   
            enddo                                                       
         end do                                                         
         call ybtens (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,        
     *        mcidas,mciads,xc_123,yc_123,zc_123,mcnatm,amatbi_123,     
     *        amatbt_123,mcnics,mcncar,mcmics,mcmic2,mcmatm,t_123)      
c         
         do i = 1, mcmic2                                               
            do j=1, mcmics                                              
               amatbt_132(j,i) = zero                                   
            enddo                                                       
         end do                                                         
         call ybtens (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,        
     *        mcidas,mciads,xc_132,yc_132,zc_132,mcnatm,amatbi_132,     
     *        amatbt_132,mcnics,mcncar,mcmics,mcmic2,mcmatm,t_132)      
c
c     K0
c
         do i = 1, mcmic2
            amatc(i) = zero
         end do
         call formf2ij (amatc,amatbt,dxint0,mcmics,mcmic2,mcnics)
         do i = 1, mcmic2
            scr3(i) = zero
         end do
         do i = 1, mcmcar
           do j=1,mcmics
            scr(i,j) = zero
         end do
         end do
         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
         do i = 1, mcmic2                                               
            amatc_12(i) = zero                                          
         end do                                                         
         call formf2ij (amatc_12,amatbt_12,dxint0_12,mcmics,            
     *                  mcmic2,mcnics)                                  
         do i = 1, mcmic2                                               
            scr3_12(i) = zero                                           
         end do                                                         
         call tranlfj (fl_12,k0_12,mcncar,mcmca2,mcmcar)                
         call ytranfc (fl_12,amatbi_12,scr,scr3_12,amatc_12,            
     *                 mcnatm,                                          
     *                 mcmics,mcmcar,mcmic2,mcmca2,mcnics)              
         call yexpnd (scr3_12,kxint0_12,mcmic2,mcmics,mcnics,0)         
c
         do i = 1, mcmic2                                               
            amatc_23(i) = zero                                          
         end do                                                         
         call formf2ij (amatc_23,amatbt_23,dxint0_23,mcmics,            
     *                  mcmic2,mcnics)                                  
         do i = 1, mcmic2                                               
            scr3_23(i) = zero                                           
         end do                                                         
         call tranlfj (fl_23,k0_23,mcncar,mcmca2,mcmcar)                
         call ytranfc (fl_23,amatbi_23,scr,scr3_23,amatc_23,            
     *                 mcnatm,                                          
     *                 mcmics,mcmcar,mcmic2,mcmca2,mcnics)              
         call yexpnd (scr3_23,kxint0_23,mcmic2,mcmics,mcnics,0)         
c         
         do i = 1, mcmic2                                               
            amatc_13(i) = zero                                          
         end do                                                         
         call formf2ij (amatc_13,amatbt_13,dxint0_13,mcmics,            
     *                  mcmic2,mcnics)                                  
         do i = 1, mcmic2                                               
            scr3_13(i) = zero                                           
         end do                                                         
         call tranlfj (fl_13,k0_13,mcncar,mcmca2,mcmcar)                
         call ytranfc (fl_13,amatbi_13,scr,scr3_13,amatc_13,            
     *                 mcnatm,                                          
     *                 mcmics,mcmcar,mcmic2,mcmca2,mcnics)              
         call yexpnd (scr3_13,kxint0_13,mcmic2,mcmics,mcnics,0)         
c         
         do i = 1, mcmic2                                               
            amatc_123(i) = zero                                         
         end do                                                         
         call formf2ij (amatc_123,amatbt_123,dxint0_123,mcmics,         
     *                  mcmic2,mcnics)                                  
         do i = 1, mcmic2                                               
            scr3_123(i) = zero                                          
         end do                                                         
         call tranlfj (fl_123,k0_123,mcncar,mcmca2,mcmcar)              
         call ytranfc (fl_123,amatbi_123,scr,scr3_123,amatc_123,        
     *                 mcnatm,                                          
     *                 mcmics,mcmcar,mcmic2,mcmca2,mcnics)              
         call yexpnd (scr3_123,kxint0_123,mcmic2,mcmics,mcnics,0)       
c         
         do i = 1, mcmic2                                               
            amatc_132(i) = zero                                         
         end do                                                         
         call formf2ij (amatc_132,amatbt_132,dxint0_132,mcmics,         
     *                  mcmic2,mcnics)                                  
         do i = 1, mcmic2                                               
            scr3_132(i) = zero                                          
         end do                                                         
         call tranlfj (fl_132,k0_132,mcncar,mcmca2,mcmcar)              
         call ytranfc (fl_132,amatbi_132,scr,scr3_132,amatc_132,        
     *                 mcnatm,                                          
     *                 mcmics,mcmcar,mcmic2,mcmca2,mcnics)              
         call yexpnd (scr3_132,kxint0_132,mcmic2,mcmics,mcnics,0)       
c
c     K1
c
         do i = 1, mcmic2
            amatc(i) = zero
         end do
          do i=1, mcmca2
            fl(i) = zero
            fl_12(i) = zero
            fl_23(i) = zero
            fl_13(i) = zero
            fl_123(i) = zero
            fl_132(i) = zero
         end do
         call formf2ij (amatc,amatbt,dxint1avE,mcmics,mcmic2,mcnics)
         do i = 1, mcmic2
            scr3(i) = zero
         end do
         do i = 1, mcmcar
           do j=1,mcmics
            scr(i,j) = zero
         end do
         end do
         call tranlfj (fl,k1avE,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
         do i = 1, mcmic2                                               
            amatc_12(i) = zero                                          
         end do                                                         
         call formf2ij (amatc_12,amatbt_12,dxint1av12,mcmics,           
     *                  mcmic2,mcnics)                                  
         do i = 1, mcmic2                                               
            scr3_12(i) = zero                                           
         end do                                                         
         call tranlfj (fl_12,k1av12,mcncar,mcmca2,mcmcar)               
         call ytranfc (fl_12,amatbi_12,scr,scr3_12,amatc_12,            
     *                 mcnatm,                                          
     *                 mcmics,mcmcar,mcmic2,mcmca2,mcnics)              
         call yexpnd (scr3_12,kxint1_12,mcmic2,mcmics,mcnics,0)         
c
         do i = 1, mcmic2                                               
            amatc_23(i) = zero                                          
         end do                                                         
         call formf2ij (amatc_23,amatbt_23,dxint1av23,mcmics,           
     *                  mcmic2,mcnics)                                  
         do i = 1, mcmic2                                               
            scr3_23(i) = zero                                           
         end do                                                         
         call tranlfj (fl_23,k1av23,mcncar,mcmca2,mcmcar)               
         call ytranfc (fl_23,amatbi_23,scr,scr3_23,amatc_23,            
     *                 mcnatm,                                          
     *                 mcmics,mcmcar,mcmic2,mcmca2,mcnics)              
         call yexpnd (scr3_23,kxint1_23,mcmic2,mcmics,mcnics,0)         
c         
         do i = 1, mcmic2                                               
            amatc_13(i) = zero                                          
         end do                                                         
         call formf2ij (amatc_13,amatbt_13,dxint1av13,mcmics,           
     *                  mcmic2,mcnics)                                  
         do i = 1, mcmic2                                               
            scr3_13(i) = zero                                           
         end do                                                         
         call tranlfj (fl_13,k1av13,mcncar,mcmca2,mcmcar)               
         call ytranfc (fl_13,amatbi_13,scr,scr3_13,amatc_13,            
     *                 mcnatm,                                          
     *                 mcmics,mcmcar,mcmic2,mcmca2,mcnics)              
         call yexpnd (scr3_13,kxint1_13,mcmic2,mcmics,mcnics,0)         
c         
         do i = 1, mcmic2                                               
            amatc_123(i) = zero                                         
         end do                                                         
         call formf2ij (amatc_123,amatbt_123,dxint1av123,mcmics,        
     *                  mcmic2,mcnics)                                  
         do i = 1, mcmic2                                               
            scr3_123(i) = zero                                          
         end do                                                         
         call tranlfj (fl_123,k1av123,mcncar,mcmca2,mcmcar)             
         call ytranfc (fl_123,amatbi_123,scr,scr3_123,                  
     *                 amatc_123,                                       
     *                 mcnatm,                                          
     *                 mcmics,mcmcar,mcmic2,mcmca2,mcnics)              
         call yexpnd (scr3_123,kxint1_123,mcmic2,mcmics,mcnics,0)       
c         
         do i = 1, mcmic2                                               
            amatc_132(i) = zero                                         
         end do                                                         
         call formf2ij (amatc_132,amatbt_132,dxint1av132,mcmics,        
     *                  mcmic2,mcnics)                                  
         do i = 1, mcmic2                                               
            scr3_132(i) = zero                                          
         end do                                                         
         call tranlfj (fl_132,k1av132,mcncar,mcmca2,mcmcar)             
         call ytranfc (fl_132,amatbi_132,scr,scr3_132,                  
     *                 amatc_132,                                       
     *                 mcnatm,                                          
     *                 mcmics,mcmcar,mcmic2,mcmca2,mcnics)               
         call yexpnd (scr3_132,kxint1_132,mcmic2,mcmics,mcnics,0)       
c
c     K2
c
         do i = 1, mcmic2
            amatc(i) = zero
         end do
         call formf2ij (amatc,amatbt,dxint2avE,mcmics,mcmic2,mcnics)
         do i = 1, mcmic2
            scr3(i) = zero
         end do
         do i = 1, mcmcar
           do j=1,mcmics
            scr(i,j) = zero
         end do
         end do
         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
         do i = 1, mcmic2                                               
            amatc_12(i) = zero                                          
         end do                                                         
         call formf2ij (amatc_12,amatbt_12,dxint2av12,mcmics,           
     *                  mcmic2,mcnics)                                  
         do i = 1, mcmic2                                               
            scr3_12(i) = zero                                           
         end do                                                         
         do i = 1, mcmcar                                               
           do j=1,mcmics                                                
            scr_12(i,j) = zero                                          
         end do                                                         
         end do                                                         
         call tranlfj (fl_12,k2av12,mcncar,mcmca2,mcmcar)               
         call ytranfc (fl_12,amatbi_12,scr,scr3_12,amatc_12,            
     *                 mcnatm,                                          
     *                 mcmics,mcmcar,mcmic2,mcmca2,mcnics)              
         call yexpnd (scr3_12,kxint2_12,mcmic2,mcmics,mcnics,0)         
c
         do i = 1, mcmic2                                               
            amatc_23(i) = zero                                          
         end do                                                         
         call formf2ij (amatc_23,amatbt_23,dxint2av23,mcmics,           
     *                  mcmic2,mcnics)                                  
         do i = 1, mcmic2                                               
            scr3_23(i) = zero                                           
         end do                                                         
         call tranlfj (fl_23,k2av23,mcncar,mcmca2,mcmcar)               
         call ytranfc (fl_23,amatbi_23,scr,scr3_23,                     
     *                 amatc_23,                                        
     *                 mcnatm,                                          
     *                 mcmics,mcmcar,mcmic2,mcmca2,mcnics)              
         call yexpnd (scr3_23,kxint2_23,mcmic2,mcmics,mcnics,0)         
c         
         do i = 1, mcmic2                                               
            amatc_13(i) = zero                                          
         end do                                                         
         call formf2ij (amatc_13,amatbt_13,dxint2av13,mcmics,           
     *                  mcmic2,mcnics)                                  
         do i = 1, mcmic2                                               
            scr3_13(i) = zero                                           
         end do                                                         
         call tranlfj (fl_13,k2av13,mcncar,mcmca2,mcmcar)               
         call ytranfc (fl_13,amatbi_13,scr,scr3_13,amatc_13,            
     *                 mcnatm,                                          
     *                 mcmics,mcmcar,mcmic2,mcmca2,mcnics)              
         call yexpnd (scr3_13,kxint2_13,mcmic2,mcmics,mcnics,0)         
c         
         do i = 1, mcmic2                                               
            amatc_123(i) = zero                                         
         end do                                                         
         call formf2ij (amatc_123,amatbt_123,dxint2av123,mcmics,        
     *                  mcmic2,mcnics)                                  
         do i = 1, mcmic2                                               
            scr3_123(i) = zero                                          
         end do                                                         
         call tranlfj (fl_123,k2av123,mcncar,mcmca2,mcmcar)             
         call ytranfc (fl_123,amatbi_123,scr,scr3_123,                  
     *                 amatc_123,                                       
     *                 mcnatm,                                          
     *                 mcmics,mcmcar,mcmic2,mcmca2,mcnics)              
         call yexpnd (scr3_123,kxint2_123,mcmic2,mcmics,mcnics,0)       
c         
         do i = 1, mcmic2                                               
            amatc_132(i) = zero                                         
         end do                                                         
         call formf2ij (amatc_132,amatbt_132,dxint2av132,mcmics,        
     *                  mcmic2,mcnics)                                  
         do i = 1, mcmic2                                               
            scr3_132(i) = zero                                          
         end do                                                         
         call tranlfj (fl_132,k2av132,mcncar,mcmca2,mcmcar)             
         call ytranfc (fl_132,amatbi_132,scr,scr3_132,                  
     *                 amatc_132,                                       
     *                 mcnatm,                                          
     *                 mcmics,mcmcar,mcmic2,mcmca2,mcnics)              
         call yexpnd (scr3_132,kxint2_132,mcmic2,mcmics,mcnics,0)       
c
c     Now calculated the differences: g-gk and f-fk : 6/9/99 by Y. Kim
c
         do i=1,mcnics
            dxint1(i) = dxint1avE(i) - dxint0(i)
            dxint1_12(i) = dxint1av12(i) - dxint0_12(i)                 
            dxint1_23(i) = dxint1av23(i) - dxint0_23(i)                 
            dxint1_13(i) = dxint1av13(i) - dxint0_13(i)                 
            dxint1_123(i) = dxint1av123(i) - dxint0_123(i)              
            dxint1_132(i) = dxint1av132(i) - dxint0_132(i)              
c
            dxint2(i) = dxint2avE(i) - dxint0(i)
            dxint2_12(i) = dxint2av12(i) - dxint0_12(i)                 
            dxint2_23(i) = dxint2av23(i) - dxint0_23(i)                 
            dxint2_13(i) = dxint2av13(i) - dxint0_13(i)                 
            dxint2_123(i) = dxint2av123(i) - dxint0_123(i)              
            dxint2_132(i) = dxint2av132(i) - dxint0_132(i)              
               do j=1,mcnics
                  kxint1(j,i) = kxint1(j,i) - kxint0(j,i)
            kxint1_12(j,i) = kxint1_12(j,i) - kxint0_12(j,i)            
            kxint1_23(j,i) = kxint1_23(j,i) - kxint0_23(j,i)            
            kxint1_13(j,i) = kxint1_13(j,i) - kxint0_13(j,i)            
            kxint1_123(j,i) = kxint1_123(j,i) - kxint0_123(j,i)         
            kxint1_132(j,i) = kxint1_132(j,i) - kxint0_132(j,i)         
                  kxint2(j,i) = kxint2(j,i) - kxint0(j,i)               
            kxint2_12(j,i) = kxint2_12(j,i) - kxint0_12(j,i)            
            kxint2_23(j,i) = kxint2_23(j,i) - kxint0_23(j,i)            
            kxint2_13(j,i) = kxint2_13(j,i) - kxint0_13(j,i)            
            kxint2_123(j,i) = kxint2_123(j,i) - kxint0_123(j,i)         
            kxint2_132(j,i) = kxint2_132(j,i) - kxint0_132(j,i)         
               enddo
         enddo
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 i=1,mcnics
            bevbm(i,mciesp) = dxint1(i)/va + dxint2(i)/vb
         enddo
         do i=1,mcnics                                                  
            bevbm_12(i,mciesp) = dxint1_12(i)/va +                      
     *                           dxint2_12(i)/vb                        
         enddo                                                          
         do i=1,mcnics                                                  
            bevbm_23(i,mciesp) = dxint1_23(i)/va +                      
     *                           dxint2_23(i)/vb                        
         enddo                                                          
         do i=1,mcnics                                                  
            bevbm_13(i,mciesp) = dxint1_13(i)/va +                      
     *                           dxint2_13(i)/vb                        
         enddo                                                          
         do i=1,mcnics                                                  
            bevbm_123(i,mciesp) = dxint1_123(i)/va +                    
     *                           dxint2_123(i)/vb                       
         enddo                                                          
         do i=1,mcnics                                                  
            bevbm_132(i,mciesp) = dxint1_132(i)/va +                    
     *                           dxint2_132(i)/vb                       
         enddo                                                          
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 j=1,mcnics
              do i= 1, j
                 cevbm(i,j,mciesp) = (dxint1(i)*dxint1(j))/(va*va) +
     *                               (dxint2(i)*dxint2(j))/(vb*vb) -
     *                               kxint1(i,j)/va  -
     *                               kxint2(i,j)/vb
      cevbm(j,i,mciesp) = cevbm(i,j,mciesp) 
      cevbm_12(i,j,mciesp) = (dxint1_12(i)*dxint1_12(j))/(va*va) +
     *                       (dxint2_12(i)*dxint2_12(j))/(vb*vb) -
     *                          kxint1_12(i,j)/va  -
     *                          kxint2_12(i,j)/vb
                 cevbm_12(j,i,mciesp) = cevbm_12(i,j,mciesp)
              enddo
           enddo
c
c     and mcifre=2
c
        else if (mcifre.eq.2)then                                      
           do j=1,mcnics                                              
              do 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
         cevbm_12(i,j,mciesp)=(dxint1_12(i)*dxint2_12(j))/(va*vb)+    
     *   (dxint2_12(i)*dxint1_12(j))/(va*vb)+      
     *   kxint1_12(i,j)/va + kxint2_12(i,j)/vb
         cevbm_23(i,j,mciesp)=(dxint1_23(i)*dxint2_23(j))/(va*vb)+
     *   (dxint2_23(i)*dxint1_23(j))/(va*vb)+
     *   kxint1_23(i,j)/va + kxint2_23(i,j)/vb
         cevbm_13(i,j,mciesp)=(dxint1_13(i)*dxint2_13(j))/(va*vb)+
     *   (dxint2_13(i)*dxint1_13(j))/(va*vb)+
     *   kxint1_13(i,j)/va + kxint2_13(i,j)/vb
         cevbm_123(i,j,mciesp)=(dxint1_123(i)*dxint2_123(j))/(va*vb)+
     *   (dxint2_123(i)*dxint1_123(j))/(va*vb)+
     *   kxint1_123(i,j)/va + kxint2_123(i,j)/vb
         cevbm_132(i,j,mciesp)=(dxint1_132(i)*dxint2_132(j))/(va*vb)+
     *   (dxint2_132(i)*dxint1_132(j))/(va*vb)+
     *   kxint1_132(i,j)/va + kxint2_132(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
              enddo
           enddo
        endif
c
c     End of the loop over the mcnesp points
c
      enddo
c
c
      return
      end
c***********************************************************************
c     mctesis3
c***********************************************************************
c
      subroutine mctesis3(redun)
c
c     This subroutine is analogous to mctesi. It calculates the D, b, and C
c     coefficients for each symmetrically equivalent Shepard point.
c     (O.T. October 2006)
c
      implicit double precision (a-h,o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      parameter (zero   = 0.0d0 )  
      parameter (mcmca2=mcmcar*(mcmcar+1)/2)
      parameter (mcmic2=mcmics*(mcmics+1)/2)
c
      dimension x0(mcmcar)                  
      dimension x0_12(mcmcar)                                           
      dimension x0_23(mcmcar)                                           
      dimension x0_13(mcmcar)                                           
      dimension x0_123(mcmcar)                                          
      dimension x0_132(mcmcar)                                          
      dimension d0(mcmcar),d1(mcmcar),d2(mcmcar)                        
      dimension d0_E(mcmcar),d1_E(mcmcar),d2_E(mcmcar)                  
      dimension d0_12(mcmcar),d1_12(mcmcar),d2_12(mcmcar)               
      dimension d0_23(mcmcar),d1_23(mcmcar),d2_23(mcmcar)               
      dimension d0_13(mcmcar),d1_13(mcmcar),d2_13(mcmcar)                
      dimension d0_123(mcmcar),d1_123(mcmcar),d2_123(mcmcar)            
      dimension d0_132(mcmcar),d1_132(mcmcar),d2_132(mcmcar)            
      dimension d1tmp(mcmcar),d2tmp(mcmcar)                             
      dimension d1av12(mcmcar),d2av12(mcmcar)                           
      dimension d1av23(mcmcar),d2av23(mcmcar)                           
      dimension d1av13(mcmcar),d2av13(mcmcar)                           
      dimension d1av123(mcmcar),d2av123(mcmcar)                         
      dimension d1av132(mcmcar),d2av132(mcmcar)                         
      dimension dxint0(mcmics),dxint1(mcmics),dxint2(mcmics)            
      dimension dxint0_12(mcmics),dxint1_12(mcmics),dxint2_12(mcmics)   
      dimension dxint0_23(mcmics),dxint1_23(mcmics),dxint2_23(mcmics)   
      dimension dxint0_13(mcmics),dxint1_13(mcmics),dxint2_13(mcmics)   
      dimension dxint0_123(mcmics),dxint1_123(mcmics),dxint2_123(mcmics)
      dimension dxint0_132(mcmics),dxint1_132(mcmics),dxint2_132(mcmics)
      dimension dxint1avE(mcmics)                                       
      dimension dxint1av12(mcmics),dxint1av23(mcmics),dxint1av13(mcmics)
      dimension dxint1av123(mcmics), dxint1av132(mcmics)                
      dimension dxint2av12(mcmics),dxint2av23(mcmics)                   
      dimension dxint2avE(mcmics)                                       
      dimension dxint2av13(mcmics),dxint2av123(mcmics)                  
      dimension dxint2av132(mcmics)                                     
c
      double precision k0(mcmcar,mcmcar),
     *                 k0_12(mcmcar,mcmcar),                            
     *                 k0_23(mcmcar,mcmcar),                            
     *                 k0_13(mcmcar,mcmcar),                            
     *                 k0_123(mcmcar,mcmcar),                           
     *                 k0_132(mcmcar,mcmcar),                           
     *                 k1(mcmcar,mcmcar),
     *                 k1_E(mcmcar,mcmcar),                             
     *                 k1_12(mcmcar,mcmcar),                            
     *                 k1_23(mcmcar,mcmcar),                            
     *                 k1_13(mcmcar,mcmcar),                            
     *                 k1_123(mcmcar,mcmcar),                           
     *                 k1_132(mcmcar,mcmcar),                           
     *                 k1av12(mcmcar,mcmcar),                           
     *                 k1av23(mcmcar,mcmcar),                           
     *                 k1av13(mcmcar,mcmcar),                           
     *                 k1av123(mcmcar,mcmcar),                          
     *                 k1av132(mcmcar,mcmcar),                          
     *                 k2(mcmcar,mcmcar),
     *                 k2_E(mcmcar,mcmcar),                             
     *                 k2_12(mcmcar,mcmcar),                            
     *                 k2_23(mcmcar,mcmcar),                            
     *                 k2_13(mcmcar,mcmcar),                            
     *                 k2_123(mcmcar,mcmcar),                           
     *                 k2_132(mcmcar,mcmcar)                            
      double precision kxint0(mcmics,mcmics),
     *                 kxint0_12(mcmics,mcmics),                        
     *                 kxint0_23(mcmics,mcmics),                        
     *                 kxint0_13(mcmics,mcmics),                        
     *                 kxint0_123(mcmics,mcmics),                       
     *                 kxint0_132(mcmics,mcmics),                       
     *                 kxint1(mcmics,mcmics),
     *                 kxint1_12(mcmics,mcmics),                        
     *                 kxint1_23(mcmics,mcmics),                        
     *                 kxint1_13(mcmics,mcmics),                        
     *                 kxint1_123(mcmics,mcmics),                       
     *                 kxint1_132(mcmics,mcmics),                       
     *                 kxint2(mcmics,mcmics),
     *                 kxint2_12(mcmics,mcmics),                        
     *                 kxint2_23(mcmics,mcmics),                        
     *                 kxint2_13(mcmics,mcmics),                        
     *                 kxint2_123(mcmics,mcmics),                       
     *                 kxint2_132(mcmics,mcmics),                       
     *                 k2av12(mcmcar,mcmcar),                           
     *                 k2av23(mcmcar,mcmcar),                           
     *                 k2av13(mcmcar,mcmcar),                           
     *                 k2av123(mcmcar,mcmcar),                          
     *                 k2av132(mcmcar,mcmcar),                          
     *                 xlooker1(mcmcar,mcmcar),                         
     *                 xlooker2(mcmcar,mcmcar),                         
     *                 xlooker3(mcmcar,mcmcar),                         
     *                 xlooker3a(mcmcar,mcmcar),                        
     *                 xlooker4(mcmcar,mcmcar),                         
     *                 xlooker5(mcmcar,mcmcar),                         
     *                 k1avE(mcmcar,mcmcar),                            
     *                 k0_12t(mcmcar,mcmcar)                            
c
      dimension dics(mcmics)
      dimension dics_12(mcmics)                                         
      dimension dics_23(mcmics)                                         
      dimension dics_13(mcmics)                                         
      dimension dics_123(mcmics)                                        
      dimension dics_132(mcmics)                                        
      dimension dicd(mcmicd)
      dimension dicd_12(mcmicd)                                         
      dimension dicd_23(mcmicd)                                         
      dimension dicd_13(mcmicd)                                         
      dimension dicd_123(mcmicd)                                        
      dimension dicd_132(mcmicd)                                        
      dimension xc(mcmatm),yc(mcmatm),zc(mcmatm)
      dimension xc_12(mcmatm),yc_12(mcmatm),zc_12(mcmatm)               
      dimension xc_23(mcmatm),yc_23(mcmatm),zc_23(mcmatm)               
      dimension xc_13(mcmatm),yc_13(mcmatm),zc_13(mcmatm)               
      dimension xc_123(mcmatm),yc_123(mcmatm),zc_123(mcmatm)            
      dimension xc_132(mcmatm),yc_132(mcmatm),zc_132(mcmatm)            
      dimension amatb(mcmics,mcmcar)
      dimension amatb_12(mcmics,mcmcar)                                 
      dimension amatb_23(mcmics,mcmcar)                                 
      dimension amatb_13(mcmics,mcmcar)                                 
      dimension amatb_123(mcmics,mcmcar)                                
      dimension amatb_132(mcmics,mcmcar)                                
      dimension amatbi(mcmcar,mcmics)
      dimension amatbi_12(mcmcar,mcmics)                                
      dimension amatbi_23(mcmcar,mcmics)                                
      dimension amatbi_13(mcmcar,mcmics)                                
      dimension amatbi_123(mcmcar,mcmics)                               
      dimension amatbi_132(mcmcar,mcmics)                               
      dimension amatbt(mcmics,mcmic2)
      dimension amatbt_12(mcmics,mcmic2)                                
      dimension amatbt_23(mcmics,mcmic2)                                
      dimension amatbt_13(mcmics,mcmic2)                                
      dimension amatbt_123(mcmics,mcmic2)                               
      dimension amatbt_132(mcmics,mcmic2)                               
      dimension amatc(mcmic2)
      dimension amatc_12(mcmic2)                                        
      dimension amatc_23(mcmic2)                                        
      dimension amatc_13(mcmic2)                                        
      dimension amatc_123(mcmic2)                                       
      dimension amatc_132(mcmic2)                                       
      dimension egnm(mcmics,mcmics) 
      dimension egnm_12(mcmics,mcmics)                                  
      dimension egnm_23(mcmics,mcmics)                                  
      dimension egnm_13(mcmics,mcmics)                                  
      dimension egnm_123(mcmics,mcmics)                                 
      dimension egnm_132(mcmics,mcmics)                                 
      dimension ggi(mcmics,mcmics)
      dimension ggi_12(mcmics,mcmics)                                   
      dimension ggi_23(mcmics,mcmics)                                   
      dimension ggi_13(mcmics,mcmics)                                   
      dimension ggi_123(mcmics,mcmics)                                  
      dimension ggi_132(mcmics,mcmics)                                  
      dimension gm(mcmics,mcmics)
      dimension amasin(mcmcar,mcmcar)
      dimension amasin_12(mcmcar,mcmcar)                                
      dimension amasin_23(mcmcar,mcmcar)                                
      dimension amasin_13(mcmcar,mcmcar)                                
      dimension amasin_123(mcmcar,mcmcar)                               
      dimension amasin_132(mcmcar,mcmcar)                               
      dimension flgm(mcmics)
      dimension scr(mcmcar,mcmics)
      dimension scr_12(mcmcar,mcmics)                                   
      dimension scr_23(mcmcar,mcmics)                                   
      dimension scr_13(mcmcar,mcmics)                                   
      dimension scr_123(mcmcar,mcmics)                                  
      dimension scr_132(mcmcar,mcmics)                                  
      dimension scr3(mcmic2)
      dimension scr3_12(mcmic2)                                         
      dimension scr3_23(mcmic2)                                         
      dimension scr3_13(mcmic2)                                         
      dimension scr3_123(mcmic2)                                        
      dimension scr3_132(mcmic2)                                        
      dimension fl(mcmca2)
      dimension fl_12(mcmca2)                                           
      dimension fl_23(mcmca2)                                           
      dimension fl_13(mcmca2)                                           
      dimension fl_123(mcmca2)                                          
      dimension fl_132(mcmca2)                                          
c
      logical redun
c
c     Define some variables
c
      mcncar = 3*mcnatm
c
c initialization                                                        
        v1=zero                                                         
        v2=zero                                                         
        v1_E=zero                                                       
        v1_12=zero                                                      
        v1_23=zero                                                      
        v1_13=zero                                                      
        v1_123=zero                                                     
        v1_132=zero                                                     
        v2_E=zero                                                       
        v2_12=zero                                                      
        v2_23=zero                                                      
        v2_13=zero                                                      
        v2_123=zero                                                     
        v2_132=zero                                                     
        expsum=zero                                                     
        expsum_2=zero                                                   
        do i=1,mcmics
            dxint0(i)=zero
            dxint0_12(i)=zero                                           
            dxint0_23(i)=zero                                           
            dxint0_13(i)=zero                                           
            dxint0_123(i)=zero                                          
            dxint0_132(i)=zero                                          
            dxint1(i)=zero
            dxint1_12(i)=zero                                           
            dxint1_23(i)=zero                                           
            dxint1_13(i)=zero                                           
            dxint1_123(i)=zero                                          
            dxint1_132(i)=zero                                          
            dxint2(i)=zero
            dxint2_12(i)=zero                                           
            dxint2_23(i)=zero                                           
            dxint2_13(i)=zero                                           
            dxint2_123(i)=zero                                          
            dxint2_132(i)=zero                                          
            dxint1avE(i)=zero                                           
            dxint1av12(i)=zero                                          
            dxint1av23(i)=zero                                          
            dxint1av13(i)=zero                                          
            dxint1av123(i)=zero                                         
            dxint1av132(i)=zero                                         
            dxint2avE(i)=zero                                           
            dxint2av12(i)=zero                                           
            dxint2av23(i)=zero                                          
            dxint2av13(i)=zero                                          
            dxint2av123(i)=zero                                         
            dxint2av132(i)=zero                                         
             do j=1,mcmics
               kxint0(i,j)=zero
               kxint0_12(i,j)=zero                                   
               kxint0_23(i,j)=zero                                   
               kxint0_13(i,j)=zero                                   
               kxint0_123(i,j)=zero                                  
               kxint0_132(i,j)=zero                                  
             enddo
             do j=1,mcmics
               kxint1(i,j)=zero
               kxint1_12(i,j)=zero                                   
               kxint1_23(i,j)=zero                                   
               kxint1_13(i,j)=zero                                   
               kxint1_123(i,j)=zero                                  
               kxint1_132(i,j)=zero                                  
             enddo 
             do j=1,mcmics
               kxint2(i,j)=zero
               kxint2_12(i,j)=zero                                   
               kxint2_23(i,j)=zero                                   
               kxint2_13(i,j)=zero                                   
               kxint2_123(i,j)=zero                                  
               kxint2_132(i,j)=zero                                  
             enddo
        enddo 
        do ih=1,mcmcar                                                
          x0(ih)=zero                                                 
          x0_12(ih)=zero                                              
          x0_23(ih)=zero                                              
          x0_13(ih)=zero                                              
          x0_123(ih)=zero                                             
          x0_132(ih)=zero                                             
          d0(ih)=zero                                                 
          d0_12(ih)=zero                                              
          d0_23(ih)=zero                                              
          d0_13(ih)=zero                                              
          d0_123(ih)=zero                                             
          d0_132(ih)=zero                                             
          d1(ih)=zero                                                 
          d1_E(ih)=zero                                               
          d1_12(ih)=zero                                              
          d1_23(ih)=zero                                              
          d1_13(ih)=zero                                              
          d1_123(ih)=zero                                             
          d1_132(ih)=zero                                             
          d1tmp(ih)=zero                                              
          d1av12(ih)=zero                                             
          d1av23(ih)=zero                                             
          d1av13(ih)=zero                                             
          d1av123(ih)=zero                                            
          d1av132(ih)=zero                                            
          d2av12(ih)=zero                                             
          d2av23(ih)=zero                                             
          d2av13(ih)=zero                                             
          d2av123(ih)=zero                                            
          d2av132(ih)=zero                                            
          d2(ih)=zero                                                 
          d2_E(ih)=zero                                               
          d2_12(ih)=zero                                              
          d2_23(ih)=zero                                              
          d2_13(ih)=zero                                              
          d2_123(ih)=zero                                             
          d2_132(ih)=zero                                             
          do jh=1,mcmcar                                              
            k0(ih,jh)=zero                                          
            k0_12(ih,jh)=zero                                       
            k0_23(ih,jh)=zero                                       
            k0_13(ih,jh)=zero                                       
            k0_123(ih,jh)=zero                                       
            k0_132(ih,jh)=zero                                      
            k1(ih,jh)=zero                                          
            k1_E(ih,jh)=zero                                        
            k1_12(ih,jh)=zero                                       
            k1_23(ih,jh)=zero                                       
            k1_13(ih,jh)=zero                                       
            k1_123(ih,jh)=zero                                      
            k1_132(ih,jh)=zero                                      
            k1avE(ih,jh)=zero                                       
            k1av12(ih,jh)=zero                                      
            k1av23(ih,jh)=zero                                      
            k1av13(ih,jh)=zero                                      
            k1av123(ih,jh)=zero                                      
            k1av132(ih,jh)=zero                                     
            k2(ih,jh)=zero                                          
            k2_E(ih,jh)=zero                                        
            k2_12(ih,jh)=zero                                       
            k2_23(ih,jh)=zero                                       
            k2_13(ih,jh)=zero                                       
            k2_123(ih,jh)=zero                                      
            k2_132(ih,jh)=zero                                      
            k2av12(ih,jh)=zero                                      
            k2av23(ih,jh)=zero                                      
            k2av13(ih,jh)=zero                                      
            k2av123(ih,jh)=zero                                     
            k2av132(ih,jh)=zero                                     
            xlooker1(ih,jh)=zero                                    
            xlooker2(ih,jh)=zero                                    
            xlooker3(ih,jh)=zero                                    
            xlooker3a(ih,jh)=zero                                   
            xlooker4(ih,jh)=zero                                    
            xlooker5(ih,jh)=zero                                    
            k0_12t(ih,jh)=zero                                      
          enddo                                                         
        enddo                                                           
c
c     Start a loop over the mcnesp (electronic structure theory Shepard points)
c
      do mciesp=1,mcnesp
c
c     Put the Shepard point information into the working arrays
c
         v0=vsh(mciesp)
         do i=1,mcncar
            x0(i)=xsh(i,mciesp)
            d0(i)=dsh(i,mciesp)
            do j=1,mcncar
               k0(i,j)=hsh(i,j,mciesp)
            enddo
         enddo
c Permutation of rows in arrays with Shepard point geom and grad        
          call mc12perm(x0_12,x0)                                       
          call mc12perm(d0_12,d0)                                       
          call mc23perm(x0_23,x0)                                        
          call mc23perm(d0_23,d0)                                       
          call mc13perm(x0_13,x0)                                       
          call mc13perm(d0_13,d0)                                       
          call mc123perm(x0_123,x0)                                     
          call mc123perm(d0_123,d0)                                     
          call mc132perm(x0_132,x0)                                     
          call mc132perm(d0_132,d0)                                     
c Permutation of rows and columns in Hessian matrices at Shepard points
         if (mcihfr.ne.0) then
           call mc12perm2(k0_12,k0)                                   
           call mc23perm2(k0_23,k0)                                   
           call mc13perm2(k0_13,k0)                                   
           call mc13perm2(k0_12t,k0)                                  
           call mc23perm2(k0_123,k0_12t)
c                              
           do i=1,mcncar                                                 
           do j=1,mcncar                                                 
            k0_12t(i,j)=0.d0                                             
            enddo                                                        
            enddo                                                        
           call mc12perm2(k0_12t,k0)                                  
           call mc23perm2(k0_132,k0_12t)                              
           do i=1,mcncar                                                 
           do j=1,mcncar                                                 
            k0_12t(i,j)=0.d0                                             
            enddo                                                        
            enddo
          endif                                                        
c
c     Calculate v1, d1 and k1 by means of a mcviic call.
cOT  These are now calculated n!=6 times for each permutation.          
c
         if (mcihfr.ne.0) then
         call mcviic(x0,v1_E,d1_E,k1_E,3,1,1)                             
         call mcviic(x0_12,v1_12,d1_12,k1_12,3,1,1)                         
         call mcviic(x0_23,v1_23,d1_23,k1_23,3,1,1)                         
         call mcviic(x0_13,v1_13,d1_13,k1_13,3,1,1)                         
         call mcviic(x0_123,v1_123,d1_123,k1_123,3,1,1)                     
         call mcviic(x0_132,v1_132,d1_132,k1_132,3,1,1)      
c
         else
c
         call mcviic(x0,v1_E,d1_E,k1_E,2,1,1)
         call mcviic(x0_12,v1_12,d1_12,k1_12,2,1,1)
         call mcviic(x0_23,v1_23,d1_23,k1_23,2,1,1)
         call mcviic(x0_13,v1_13,d1_13,k1_13,2,1,1)
         call mcviic(x0_123,v1_123,d1_123,k1_123,2,1,1)
         call mcviic(x0_132,v1_132,d1_132,k1_132,2,1,1)
c
         endif               
c
         exxp1 = dexp(-alphaV1*v1_E)                                    
         exxp2 = dexp(-alphaV1*v1_12)                                   
         exxp3 = dexp(-alphaV1*v1_23)                                   
         exxp4 = dexp(-alphaV1*v1_13)                                   
         exxp5 = dexp(-alphaV1*v1_123)                                  
         exxp6 = dexp(-alphaV1*v1_132)                                  
c
         v1=-(1.d0/alphaV1)*dlog(1.d0/isigmav1*(exxp1+exxp2             
     *   +exxp3+exxp4+exxp5+exxp6))                                     
c
         expsum=exxp1+exxp2+exxp3+exxp4+exxp5+exxp6                     
c
c Symmetrized gradient (\tilde{G})
         do i=1,12                                                      
          d1tmp(i)=exxp1*d1_E(i)+exxp2*d1_12(i)+exxp3*d1_23(i)          
     *    +exxp4*d1_13(i)+exxp5*d1_123(i)+exxp6*d1_132(i)               
           d1(i)=d1tmp(i)/expsum                                        
         enddo                                                          
c
          call mc12perm (d1av12,d1)                                     
          call mc23perm (d1av23,d1)                                     
          call mc13perm (d1av13,d1)                                     
          call mc123perm (d1av123,d1)                                   
          call mc132perm (d1av132,d1)                                   
c
         if (mcihfr.ne.0) then
         do i=1,mcncar                                                  
           do j=1,mcncar                                                
         xlooker1(i,j)=(k1_E(i,j)-alphaV1*d1_E(i)*d1_E(j))*exxp1+       
     *   (k1_12(i,j)-alphaV1*d1_12(i)*d1_12(j))*exxp2+                  
     *   (k1_23(i,j)-alphaV1*d1_23(i)*d1_23(j))*exxp3+                  
     *   (k1_13(i,j)-alphaV1*d1_13(i)*d1_13(j))*exxp4+                  
     * (k1_123(i,j)-alphaV1*d1_123(i)*d1_123(j))*exxp5+                 
     * (k1_132(i,j)-alphaV1*d1_132(i)*d1_132(j))*exxp6                  
            xlooker2(i,j)=xlooker1(i,j)/expsum                          
            xlooker3(i,j)=d1_E(i)*exxp1+                                
     *     d1_12(i)*exxp2+                                              
     *     d1_23(i)*exxp3+                                              
     *     d1_13(i)*exxp4+                                              
     *     d1_123(i)*exxp5+                                             
     *     d1_132(i)*exxp6                                              
           xlooker3a(i,j)=d1_E(j)*exxp1+                                
     *     d1_12(j)*exxp2+                                              
     *     d1_23(j)*exxp3+                                              
     *     d1_13(j)*exxp4+                                              
     *     d1_123(j)*exxp5+                                             
     *     d1_132(j)*exxp6                                              
           xlooker4(i,j)=alphaV1*xlooker3(i,j)*                         
     *     xlooker3a(i,j)/(expsum**2)                                   
           xlooker5(i,j)=xlooker2(i,j)+xlooker4(i,j)                    
           enddo                                                        
         enddo                                                          
           do i=1,mcncar                                                
           do j=1,mcncar                                                
           k1avE(i,j)=xlooker5(i,j)                                     
           enddo                                                        
         enddo                                                          
          call mc12perm2(k1av12,k1avE)                               
          call mc23perm2(k1av23,k1avE)                               
          call mc13perm2(k1av13,k1avE)                               
          do i=1,mcncar                                                 
          do j=1,mcncar                                                 
           k0_12t(i,j)=0.d0                                             
           enddo                                                        
           enddo                                                        
          call mc13perm2(k0_12t,k1avE)                               
          call mc23perm2(k1av123,k0_12t)                             
          do i=1,mcncar                                                 
          do j=1,mcncar                                                 
           k0_12t(i,j)=0.d0                                             
           enddo                                                        
           enddo                                                        
          call mc12perm2(k0_12t,k1avE)                               
          call mc23perm2(k1av132,k0_12t)    
         endif                         
c          
c
c     And now, the same for v2, d2, and k2:
c
         expsum=0.d0                                                    
         expsum_2=0.d0   
c
         if (mcihfr.ne.0) then
c                                               
         call mcviic(x0,v2_E,d2_E,k2_E,3,2,1)                             
         call mcviic(x0_12,v2_12,d2_12,k2_12,3,2,1)                         
         call mcviic(x0_23,v2_23,d2_23,k2_23,3,2,1)                         
         call mcviic(x0_13,v2_13,d2_13,k2_13,3,2,1)                         
         call mcviic(x0_123,v2_123,d2_123,k2_123,3,2,1)                     
         call mcviic(x0_132,v2_132,d2_132,k2_132,3,2,1)                     
c
         else
c
         call mcviic(x0,v2_E,d2_E,k2_E,2,2,1)
         call mcviic(x0_12,v2_12,d2_12,k2_12,2,2,1)
         call mcviic(x0_23,v2_23,d2_23,k2_23,2,2,1)
         call mcviic(x0_13,v2_13,d2_13,k2_13,2,2,1)
         call mcviic(x0_123,v2_123,d2_123,k2_123,2,2,1)
         call mcviic(x0_132,v2_132,d2_132,k2_132,2,2,1)
c
         endif
c
         exxp1_2 = dexp(-alphaV2*v2_E)                                  
         exxp2_2 = dexp(-alphaV2*v2_12)                                 
         exxp3_2= dexp(-alphaV2*v2_23)                                  
         exxp4_2= dexp(-alphaV2*v2_13)                                  
         exxp5_2= dexp(-alphaV2*v2_123)                                 
         exxp6_2= dexp(-alphaV2*v2_132)                                 
         v2=-(1.d0/alphaV2)*dlog(1.d0/isigmav2*(exxp1_2+exxp2_2+         
     *   exxp3_2+exxp4_2+exxp5_2+exxp6_2))                              
c
         expsum_2=exxp1_2+exxp2_2+exxp3_2+exxp4_2+exxp5+exxp6_2         
c
c Symmetrized gradient (\tilde{G_2})
         do i=1,12                                                      
          d2tmp(i)=exxp1_2*d2_E(i)+exxp2_2*d2_12(i)+exxp3_2*d2_23(i)    
     *    +exxp4_2*d2_13(i)+exxp5_2*d2_123(i)+exxp6_2*d2_132(i)         
           d2(i)=d2tmp(i)/expsum_2                                      
         enddo                                                          
c
c   d2_av_12(i) is the gradient at the "reflected" (k)-point            
          call mc12perm (d2av12,d2)                                     
          call mc23perm (d2av23,d2)                                     
          call mc13perm (d2av13,d2)                                     
          call mc123perm (d2av123,d2)                                   
          call mc132perm (d2av132,d2)                                   
c
         if (mcihfr.ne.0) then         
c
         do i=1,mcmcar                                                  
         do j=1,mcmcar                                                  
         xlooker1(i,j)=0.d0                                             
         xlooker2(i,j)=0.d0                                             
         xlooker3(i,j)=0.d0                                             
         xlooker3a(i,j)=0.d0                                            
         xlooker4(i,j)=0.d0                                             
         xlooker5(i,j)=0.d0                                             
        enddo                                                           
         enddo                                                          
         do i=1,mcncar                                                  
           do j=1,mcncar                                                
         xlooker1(i,j)=(k2_E(i,j)-alphaV2*d2_E(i)*d2_E(j))*exxp1_2+     
     *   (k2_12(i,j)-alphaV2*d2_12(i)*d2_12(j))*exxp2_2+                
     *   (k2_23(i,j)-alphaV2*d2_23(i)*d2_23(j))*exxp3_2+                
     *   (k2_13(i,j)-alphaV2*d2_13(i)*d2_13(j))*exxp4_2+                
     * (k2_123(i,j)-alphaV2*d2_123(i)*d2_123(j))*exxp5_2+               
     * (k2_132(i,j)-alphaV2*d2_132(i)*d2_132(j))*exxp6_2                
            xlooker2(i,j)=xlooker1(i,j)/expsum_2                        
            xlooker3(i,j)=d2_E(i)*exxp1_2+                              
     *     d2_12(i)*exxp2_2+                                            
     *     d2_23(i)*exxp3_2+                                            
     *     d2_13(i)*exxp4_2+                                            
     *     d2_123(i)*exxp5_2+                                           
     *     d2_132(i)*exxp6_2                                            
           xlooker3a(i,j)=d2_E(j)*exxp1_2+                              
     *     d2_12(j)*exxp2_2+                                            
     *     d2_23(j)*exxp3_2+                                            
     *     d2_13(j)*exxp4_2+                                            
     *     d2_123(j)*exxp5_2+                                           
     *     d2_132(j)*exxp6_2                                            
           xlooker4(i,j)=alphaV2*xlooker3(i,j)*                         
     *     xlooker3a(i,j)/(expsum_2**2)                                 
           xlooker5(i,j)=xlooker2(i,j)+xlooker4(i,j)                     
           enddo                                                        
         enddo                                                          
           do i=1,mcncar                                                
           do j=1,mcncar                                                
           k2(i,j)=xlooker5(i,j)                                        
           enddo                                                        
         enddo                                                          
          call mc12perm2(k2av12,k2)                                  
          call mc23perm2(k2av23,k2)                                  
          call mc13perm2(k2av13,k2)                                  
          do i=1,mcncar                                                 
          do j=1,mcncar                                                 
           k0_12t(i,j)=0.d0                                             
          enddo                                                         
          enddo                                                         
          call mc13perm2(k0_12t,k2)                                  
          call mc23perm2(k2av123,k0_12t)                             
          do i=1,mcncar                                                 
          do j=1,mcncar                                                 
           k0_12t(i,j)=0.d0                                             
          enddo                                                         
          enddo                                                         
          call mc12perm2(k0_12t,k2)                                  
          call mc23perm2(k2av132,k0_12t)                             
          do i=1,mcncar                                                 
          do j=1,mcncar                                                 
           k0_12t(i,j)=0.d0                                             
          enddo                                                         
          enddo  
         endif                                         
c
c     Rearrange the Cartesian coordinates:
c
         do j = 1, mcnatm
            xc(j) = x0(3*j-2)
            yc(j) = x0(3*j-1)
            zc(j) = x0(3*j)
            xc_12(j) = x0_12(3*j-2)                                     
            yc_12(j) = x0_12(3*j-1)                                     
            zc_12(j) = x0_12(3*j)                                       
            xc_23(j) = x0_23(3*j-2)                                     
            yc_23(j) = x0_23(3*j-1)                                     
            zc_23(j) = x0_23(3*j)                                       
            xc_13(j) = x0_13(3*j-2)                                          
            yc_13(j) = x0_13(3*j-1)                                     
            zc_13(j) = x0_13(3*j)                                        
            xc_123(j) = x0_123(3*j-2)                                   
            yc_123(j) = x0_123(3*j-1)                                   
            zc_123(j) = x0_123(3*j)                                     
            xc_132(j) = x0_132(3*j-2)                                   
            yc_132(j) = x0_132(3*j-1)                                   
            zc_132(j) = x0_132(3*j)                                     
         end do
c
c     Transform the cartesian coordinates of the electronic structure
c     theory Shepard points nto 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)
         call mctcic(mcndid,mcnand,mcnadd,mcndad,                       
     *               mcidid,mciand,mciadd,mcidad,                       
     *         mcmicd,mcmatm,xc_12,yc_12,zc_12,dicd_12)                 
         call mctcic(mcndid,mcnand,mcnadd,mcndad,                       
     *               mcidid,mciand,mciadd,mcidad,                       
     *         mcmicd,mcmatm,xc_23,yc_23,zc_23,dicd_23)                 
         call mctcic(mcndid,mcnand,mcnadd,mcndad,                       
     *               mcidid,mciand,mciadd,mcidad,                       
     *         mcmicd,mcmatm,xc_13,yc_13,zc_13,dicd_13)                 
         call mctcic(mcndid,mcnand,mcnadd,mcndad,                       
     *               mcidid,mciand,mciadd,mcidad,                       
     *         mcmicd,mcmatm,xc_123,yc_123,zc_123,dicd_123)             
         call mctcic(mcndid,mcnand,mcnadd,mcndad,                       
     *               mcidid,mciand,mciadd,mcidad,                       
     *         mcmicd,mcmatm,xc_132,yc_132,zc_132,dicd_132)             
         do i = 1, mcnicd
            qd0(i,mciesp) = dicd(i)
            qd0_12(i,mciesp) = dicd_12(i)                               
            qd0_23(i,mciesp) = dicd_23(i)                               
            qd0_13(i,mciesp) = dicd_13(i)                               
            qd0_123(i,mciesp) = dicd_123(i)                             
            qd0_132(i,mciesp) = dicd_132(i)                             
         end do
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)
         call mctcic(mcndis,mcnans,mcnads,mcndas,                       
     *               mcidis,mcians,mciads,mcidas,                       
     *          mcmics,mcmatm,xc_12,yc_12,zc_12,dics_12)                
         call mctcic(mcndis,mcnans,mcnads,mcndas,                       
     *               mcidis,mcians,mciads,mcidas,                       
     *          mcmics,mcmatm,xc_23,yc_23,zc_23,dics_23)                
         call mctcic(mcndis,mcnans,mcnads,mcndas,                       
     *               mcidis,mcians,mciads,mcidas,                       
     *          mcmics,mcmatm,xc_13,yc_13,zc_13,dics_13)                
         call mctcic(mcndis,mcnans,mcnads,mcndas,                       
     *               mcidis,mcians,mciads,mcidas,                       
     *      mcmics,mcmatm,xc_123,yc_123,zc_123,dics_123)                
         call mctcic(mcndis,mcnans,mcnads,mcndas,                       
     *               mcidis,mcians,mciads,mcidas,                       
     *      mcmics,mcmatm,xc_132,yc_132,zc_132,dics_132)                
         do i = 1, mcnics
            qs0(i,mciesp) = dics(i)
            qs0_12(i,mciesp) = dics_12(i)                               
            qs0_23(i,mciesp) = dics_23(i)                               
            qs0_13(i,mciesp) = dics_13(i)                               
            qs0_123(i,mciesp) = dics_123(i)                             
            qs0_132(i,mciesp) = dics_132(i)                             
         end do
         call mcybmat (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,
     *                 mcidas,mciads,xc,yc,zc,mcnatm,mcnics,
     *                 amatb,t,mcmatm,mcmics,mcmcar)
         call mcybmat (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,       
     *             mcidas,mciads,xc_12,yc_12,zc_12,mcnatm,mcnics,       
     *                 amatb_12,t,mcmatm,mcmics,mcmcar)                 
         call mcybmat (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,       
     *             mcidas,mciads,xc_23,yc_23,zc_23,mcnatm,mcnics,       
     *                 amatb_23,t,mcmatm,mcmics,mcmcar)                 
         call mcybmat (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,       
     *             mcidas,mciads,xc_13,yc_13,zc_13,mcnatm,mcnics,       
     *                 amatb_13,t,mcmatm,mcmics,mcmcar)                 
         call mcybmat (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,       
     *             mcidas,mciads,xc_123,yc_123,zc_123,mcnatm,mcnics,    
     *                 amatb_123,t,mcmatm,mcmics,mcmcar)                
         call mcybmat (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,       
     *             mcidas,mciads,xc_132,yc_132,zc_132,mcnatm,mcnics,    
     *                 amatb_132,t,mcmatm,mcmics,mcmcar)                
c
c  2) compute the A matrix
cOT 
c         redun=.true.
c
         if (redun) then
            call mcybimat2 (amatb,amatbi,cmmc,amasin,gm,ggi,flgm,
     *                      egnm,smmc,mcnatm,mcnics,mcmics,mcmcar)
            call mcybimat2 (amatb_12,amatbi_12,cmmc,amasin,gm,          
     *                      ggi,flgm,                                   
     *                      egnm,smmc,mcnatm,mcnics,mcmics,mcmcar)      
            call mcybimat2 (amatb_23,amatbi_23,cmmc,amasin,gm,          
     *                      ggi,flgm,                                   
     *                      egnm,smmc,mcnatm,mcnics,mcmics,mcmcar)      
            call mcybimat2 (amatb_13,amatbi_13,cmmc,amasin,gm,          
     *                      ggi,flgm,                                   
     *                      egnm,smmc,mcnatm,mcnics,mcmics,mcmcar)      
        call mcybimat2 (amatb_123,amatbi_123,cmmc,amasin,gm,            
     *                      ggi,flgm,                                   
     *                      egnm,smmc,mcnatm,mcnics,mcmics,mcmcar)      
        call mcybimat2 (amatb_132,amatbi_132,cmmc,amasin,gm,            
     *                      ggi,flgm,                                   
     *                      egnm,smmc,mcnatm,mcnics,mcmics,mcmcar)      
         else
            call mcybimat (amatb,amatbi,cmmc,amasin,gm,smmc,
     *                     mcnatm,mcnics,mcmics,mcmcar)
            call mcybimat (amatb_12,amatbi_12,cmmc,amasin,gm,smmc,      
     *                     mcnatm,mcnics,mcmics,mcmcar)                 
            call mcybimat (amatb_23,amatbi_23,cmmc,amasin,gm,smmc,      
     *                     mcnatm,mcnics,mcmics,mcmcar)                 
            call mcybimat (amatb_13,amatbi_13,cmmc,amasin,gm,smmc,      
     *                     mcnatm,mcnics,mcmics,mcmcar)                 
        call mcybimat (amatb_123,amatbi_123,cmmc,amasin,gm,smmc,        
     *                     mcnatm,mcnics,mcmics,mcmcar)                 
        call mcybimat (amatb_132,amatbi_132,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 (dxint0_12,amatbi_12,d0_12,mcnics,mcncar,mcmics,   
     *                mcmcar)                                           
         call trangj (dxint0_23,amatbi_23,d0_23,mcnics,mcncar,mcmics,   
     *                mcmcar)                                           
         call trangj (dxint0_13,amatbi_13,d0_13,mcnics,mcncar,mcmics,   
     *                mcmcar)                                           
         call trangj (dxint0_123,amatbi_123,d0_123,mcnics,mcncar,mcmics,
     *                mcmcar)                                           
         call trangj (dxint0_132,amatbi_132,d0_132,mcnics,mcncar,mcmics,
     *                mcmcar)                                           
c
        call trangj (dxint1avE,amatbi,d1,mcnics,mcncar,mcmics,mcmcar)   
        call trangj (dxint1av12,amatbi_12,d1av12,mcnics,mcncar,         
     *              mcmics,mcmcar)                                      
        call trangj (dxint1av23,amatbi_23,d1av23,mcnics,mcncar,         
     *              mcmics,mcmcar)                                      
        call trangj (dxint1av13,amatbi_13,d1av13,mcnics,mcncar,         
     *              mcmics,mcmcar)                                      
        call trangj (dxint1av123,amatbi_123,d1av123,mcnics,mcncar,      
     *              mcmics,mcmcar)                                      
        call trangj (dxint1av132,amatbi_132,d1av132,mcnics,mcncar,      
     *              mcmics,mcmcar)                                      
        call trangj (dxint2avE,amatbi,d2,mcnics,mcncar,mcmics,mcmcar)   
        call trangj (dxint2av12,amatbi_12,d2av12,mcnics,mcncar,         
     *              mcmics,mcmcar)                                      
        call trangj (dxint2av23,amatbi_23,d2av23,mcnics,mcncar,         
     *              mcmics,mcmcar)                                      
        call trangj (dxint2av13,amatbi_13,d2av13,mcnics,mcncar,         
     *              mcmics,mcmcar)                                      
        call trangj (dxint2av123,amatbi_123,d2av123,mcnics,mcncar,      
     *              mcmics,mcmcar)                                      
        call trangj (dxint2av132,amatbi_132,d2av132,mcnics,mcncar,      
     *              mcmics,mcmcar)                                      
c
         if (mcihfr.ne.0) then
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 i = 1, mcmic2
            do j=1, mcmics
               amatbt(j,i) = zero
            enddo
         end do
         call ybtens (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,
     *                mcidas,mciads,xc,yc,zc,mcnatm,amatbi,
     *                amatbt,mcnics,mcncar,mcmics,mcmic2,mcmatm,t)
c
         do i = 1, mcmic2                                               
            do j=1, mcmics                                              
               amatbt_12(j,i) = zero                                    
            enddo                                                       
         end do                                                         
         call ybtens (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,        
     *              mcidas,mciads,xc_12,yc_12,zc_12,mcnatm,amatbi_12,   
     *              amatbt_12,mcnics,mcncar,mcmics,mcmic2,mcmatm,t_12)  
c         
         do i = 1, mcmic2                                               
            do j=1, mcmics                                              
               amatbt_23(j,i) = zero                                    
            enddo                                                       
         end do                                                         
         call ybtens (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,        
     *              mcidas,mciads,xc_23,yc_23,zc_23,mcnatm,amatbi_23,   
     *              amatbt_23,mcnics,mcncar,mcmics,mcmic2,mcmatm,t_23)  
c         
         do i = 1, mcmic2                                               
            do j=1, mcmics                                              
               amatbt_13(j,i) = zero                                    
            enddo                                                       
         end do                                                         
         call ybtens (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,        
     *              mcidas,mciads,xc_13,yc_13,zc_13,mcnatm,amatbi_13,   
     *              amatbt_13,mcnics,mcncar,mcmics,mcmic2,mcmatm,t_13)  
c         
         do i = 1, mcmic2                                               
            do j=1, mcmics                                              
               amatbt_123(j,i) = zero                                   
            enddo                                                       
         end do                                                         
         call ybtens (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,        
     *        mcidas,mciads,xc_123,yc_123,zc_123,mcnatm,amatbi_123,     
     *        amatbt_123,mcnics,mcncar,mcmics,mcmic2,mcmatm,t_123)      
c         
         do i = 1, mcmic2                                               
            do j=1, mcmics                                              
               amatbt_132(j,i) = zero                                   
            enddo                                                       
         end do                                                         
         call ybtens (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,        
     *        mcidas,mciads,xc_132,yc_132,zc_132,mcnatm,amatbi_132,     
     *        amatbt_132,mcnics,mcncar,mcmics,mcmic2,mcmatm,t_132)      
c
c     K0
c
         do i = 1, mcmic2
            amatc(i) = zero
         end do
         call formf2ij (amatc,amatbt,dxint0,mcmics,mcmic2,mcnics)
         do i = 1, mcmic2
            scr3(i) = zero
         end do
         do i = 1, mcmcar
           do j=1,mcmics
            scr(i,j) = zero
         end do
         end do
         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
         do i = 1, mcmic2                                               
            amatc_12(i) = zero                                          
         end do                                                         
         call formf2ij (amatc_12,amatbt_12,dxint0_12,mcmics,            
     *                  mcmic2,mcnics)                                  
         do i = 1, mcmic2                                               
            scr3_12(i) = zero                                           
         end do                                                         
         call tranlfj (fl_12,k0_12,mcncar,mcmca2,mcmcar)                
         call ytranfc (fl_12,amatbi_12,scr,scr3_12,amatc_12,            
     *                 mcnatm,                                          
     *                 mcmics,mcmcar,mcmic2,mcmca2,mcnics)              
         call yexpnd (scr3_12,kxint0_12,mcmic2,mcmics,mcnics,0)         
c
         do i = 1, mcmic2                                               
            amatc_23(i) = zero                                          
         end do                                                         
         call formf2ij (amatc_23,amatbt_23,dxint0_23,mcmics,            
     *                  mcmic2,mcnics)                                  
         do i = 1, mcmic2                                               
            scr3_23(i) = zero                                           
         end do                                                         
         call tranlfj (fl_23,k0_23,mcncar,mcmca2,mcmcar)                
         call ytranfc (fl_23,amatbi_23,scr,scr3_23,amatc_23,            
     *                 mcnatm,                                          
     *                 mcmics,mcmcar,mcmic2,mcmca2,mcnics)              
         call yexpnd (scr3_23,kxint0_23,mcmic2,mcmics,mcnics,0)         
c         
         do i = 1, mcmic2                                               
            amatc_13(i) = zero                                          
         end do                                                         
         call formf2ij (amatc_13,amatbt_13,dxint0_13,mcmics,            
     *                  mcmic2,mcnics)                                  
         do i = 1, mcmic2                                               
            scr3_13(i) = zero                                           
         end do                                                         
         call tranlfj (fl_13,k0_13,mcncar,mcmca2,mcmcar)                
         call ytranfc (fl_13,amatbi_13,scr,scr3_13,amatc_13,            
     *                 mcnatm,                                          
     *                 mcmics,mcmcar,mcmic2,mcmca2,mcnics)              
         call yexpnd (scr3_13,kxint0_13,mcmic2,mcmics,mcnics,0)         
c         
         do i = 1, mcmic2                                               
            amatc_123(i) = zero                                         
         end do                                                         
         call formf2ij (amatc_123,amatbt_123,dxint0_123,mcmics,         
     *                  mcmic2,mcnics)                                  
         do i = 1, mcmic2                                               
            scr3_123(i) = zero                                          
         end do                                                         
         call tranlfj (fl_123,k0_123,mcncar,mcmca2,mcmcar)              
         call ytranfc (fl_123,amatbi_123,scr,scr3_123,amatc_123,        
     *                 mcnatm,                                          
     *                 mcmics,mcmcar,mcmic2,mcmca2,mcnics)              
         call yexpnd (scr3_123,kxint0_123,mcmic2,mcmics,mcnics,0)       
c         
         do i = 1, mcmic2                                               
            amatc_132(i) = zero                                         
         end do                                                         
         call formf2ij (amatc_132,amatbt_132,dxint0_132,mcmics,         
     *                  mcmic2,mcnics)                                  
         do i = 1, mcmic2                                               
            scr3_132(i) = zero                                          
         end do                                                         
         call tranlfj (fl_132,k0_132,mcncar,mcmca2,mcmcar)              
         call ytranfc (fl_132,amatbi_132,scr,scr3_132,amatc_132,        
     *                 mcnatm,                                          
     *                 mcmics,mcmcar,mcmic2,mcmca2,mcnics)              
         call yexpnd (scr3_132,kxint0_132,mcmic2,mcmics,mcnics,0)       
c
c     K1
c
         do i = 1, mcmic2
            amatc(i) = zero
         end do
          do i=1, mcmca2
            fl(i) = zero
            fl_12(i) = zero
            fl_23(i) = zero
            fl_13(i) = zero
            fl_123(i) = zero
            fl_132(i) = zero
         end do
         call formf2ij (amatc,amatbt,dxint1avE,mcmics,mcmic2,mcnics)
         do i = 1, mcmic2
            scr3(i) = zero
         end do
         do i = 1, mcmcar
           do j=1,mcmics
            scr(i,j) = zero
         end do
         end do
         call tranlfj (fl,k1avE,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
         do i = 1, mcmic2                                               
            amatc_12(i) = zero                                          
         end do                                                         
         call formf2ij (amatc_12,amatbt_12,dxint1av12,mcmics,           
     *                  mcmic2,mcnics)                                  
         do i = 1, mcmic2                                               
            scr3_12(i) = zero                                           
         end do                                                         
         call tranlfj (fl_12,k1av12,mcncar,mcmca2,mcmcar)               
         call ytranfc (fl_12,amatbi_12,scr,scr3_12,amatc_12,            
     *                 mcnatm,                                          
     *                 mcmics,mcmcar,mcmic2,mcmca2,mcnics)              
         call yexpnd (scr3_12,kxint1_12,mcmic2,mcmics,mcnics,0)         
c
         do i = 1, mcmic2                                               
            amatc_23(i) = zero                                          
         end do                                                         
         call formf2ij (amatc_23,amatbt_23,dxint1av23,mcmics,           
     *                  mcmic2,mcnics)                                  
         do i = 1, mcmic2                                               
            scr3_23(i) = zero                                           
         end do                                                         
         call tranlfj (fl_23,k1av23,mcncar,mcmca2,mcmcar)               
         call ytranfc (fl_23,amatbi_23,scr,scr3_23,amatc_23,            
     *                 mcnatm,                                          
     *                 mcmics,mcmcar,mcmic2,mcmca2,mcnics)              
         call yexpnd (scr3_23,kxint1_23,mcmic2,mcmics,mcnics,0)         
c         
         do i = 1, mcmic2                                               
            amatc_13(i) = zero                                          
         end do                                                         
         call formf2ij (amatc_13,amatbt_13,dxint1av13,mcmics,           
     *                  mcmic2,mcnics)                                  
         do i = 1, mcmic2                                               
            scr3_13(i) = zero                                           
         end do                                                         
         call tranlfj (fl_13,k1av13,mcncar,mcmca2,mcmcar)               
         call ytranfc (fl_13,amatbi_13,scr,scr3_13,amatc_13,            
     *                 mcnatm,                                          
     *                 mcmics,mcmcar,mcmic2,mcmca2,mcnics)              
         call yexpnd (scr3_13,kxint1_13,mcmic2,mcmics,mcnics,0)         
c         
         do i = 1, mcmic2                                               
            amatc_123(i) = zero                                         
         end do                                                         
         call formf2ij (amatc_123,amatbt_123,dxint1av123,mcmics,        
     *                  mcmic2,mcnics)                                  
         do i = 1, mcmic2                                               
            scr3_123(i) = zero                                          
         end do                                                         
         call tranlfj (fl_123,k1av123,mcncar,mcmca2,mcmcar)             
         call ytranfc (fl_123,amatbi_123,scr,scr3_123,                  
     *                 amatc_123,                                       
     *                 mcnatm,                                          
     *                 mcmics,mcmcar,mcmic2,mcmca2,mcnics)              
         call yexpnd (scr3_123,kxint1_123,mcmic2,mcmics,mcnics,0)       
c         
         do i = 1, mcmic2                                               
            amatc_132(i) = zero                                         
         end do                                                         
         call formf2ij (amatc_132,amatbt_132,dxint1av132,mcmics,        
     *                  mcmic2,mcnics)                                  
         do i = 1, mcmic2                                               
            scr3_132(i) = zero                                          
         end do                                                         
         call tranlfj (fl_132,k1av132,mcncar,mcmca2,mcmcar)             
         call ytranfc (fl_132,amatbi_132,scr,scr3_132,                  
     *                 amatc_132,                                       
     *                 mcnatm,                                          
     *                 mcmics,mcmcar,mcmic2,mcmca2,mcnics)               
         call yexpnd (scr3_132,kxint1_132,mcmic2,mcmics,mcnics,0)       
c
c     K2
c
         do i = 1, mcmic2
            amatc(i) = zero
         end do
         call formf2ij (amatc,amatbt,dxint2avE,mcmics,mcmic2,mcnics)
         do i = 1, mcmic2
            scr3(i) = zero
         end do
         do i = 1, mcmcar
           do j=1,mcmics
            scr(i,j) = zero
         end do
         end do
         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
         do i = 1, mcmic2                                               
            amatc_12(i) = zero                                          
         end do                                                         
         call formf2ij (amatc_12,amatbt_12,dxint2av12,mcmics,           
     *                  mcmic2,mcnics)                                  
         do i = 1, mcmic2                                               
            scr3_12(i) = zero                                           
         end do                                                         
         do i = 1, mcmcar                                               
           do j=1,mcmics                                                
            scr_12(i,j) = zero                                          
         end do                                                         
         end do                                                         
         call tranlfj (fl_12,k2av12,mcncar,mcmca2,mcmcar)               
         call ytranfc (fl_12,amatbi_12,scr,scr3_12,amatc_12,            
     *                 mcnatm,                                          
     *                 mcmics,mcmcar,mcmic2,mcmca2,mcnics)              
         call yexpnd (scr3_12,kxint2_12,mcmic2,mcmics,mcnics,0)         
c
         do i = 1, mcmic2                                               
            amatc_23(i) = zero                                          
         end do                                                         
         call formf2ij (amatc_23,amatbt_23,dxint2av23,mcmics,           
     *                  mcmic2,mcnics)                                  
         do i = 1, mcmic2                                               
            scr3_23(i) = zero                                           
         end do                                                         
         call tranlfj (fl_23,k2av23,mcncar,mcmca2,mcmcar)               
         call ytranfc (fl_23,amatbi_23,scr,scr3_23,                     
     *                 amatc_23,                                        
     *                 mcnatm,                                          
     *                 mcmics,mcmcar,mcmic2,mcmca2,mcnics)              
         call yexpnd (scr3_23,kxint2_23,mcmic2,mcmics,mcnics,0)         
c         
         do i = 1, mcmic2                                               
            amatc_13(i) = zero                                          
         end do                                                         
         call formf2ij (amatc_13,amatbt_13,dxint2av13,mcmics,           
     *                  mcmic2,mcnics)                                  
         do i = 1, mcmic2                                               
            scr3_13(i) = zero                                           
         end do                                                         
         call tranlfj (fl_13,k2av13,mcncar,mcmca2,mcmcar)               
         call ytranfc (fl_13,amatbi_13,scr,scr3_13,amatc_13,            
     *                 mcnatm,                                          
     *                 mcmics,mcmcar,mcmic2,mcmca2,mcnics)              
         call yexpnd (scr3_13,kxint2_13,mcmic2,mcmics,mcnics,0)         
c         
         do i = 1, mcmic2                                               
            amatc_123(i) = zero                                         
         end do                                                         
         call formf2ij (amatc_123,amatbt_123,dxint2av123,mcmics,        
     *                  mcmic2,mcnics)                                  
         do i = 1, mcmic2                                               
            scr3_123(i) = zero                                          
         end do                                                         
         call tranlfj (fl_123,k2av123,mcncar,mcmca2,mcmcar)             
         call ytranfc (fl_123,amatbi_123,scr,scr3_123,                  
     *                 amatc_123,                                       
     *                 mcnatm,                                          
     *                 mcmics,mcmcar,mcmic2,mcmca2,mcnics)              
         call yexpnd (scr3_123,kxint2_123,mcmic2,mcmics,mcnics,0)       
c         
         do i = 1, mcmic2                                               
            amatc_132(i) = zero                                         
         end do                                                         
         call formf2ij (amatc_132,amatbt_132,dxint2av132,mcmics,        
     *                  mcmic2,mcnics)                                  
         do i = 1, mcmic2                                               
            scr3_132(i) = zero                                          
         end do                                                         
         call tranlfj (fl_132,k2av132,mcncar,mcmca2,mcmcar)             
         call ytranfc (fl_132,amatbi_132,scr,scr3_132,                  
     *                 amatc_132,                                       
     *                 mcnatm,                                          
     *                 mcmics,mcmcar,mcmic2,mcmca2,mcnics)              
         call yexpnd (scr3_132,kxint2_132,mcmic2,mcmics,mcnics,0)       
c
       endif
c
c     Now calculated the differences: g-gk and f-fk : 6/9/99 by Y. Kim
c
         do i=1,mcnics
            dxint1(i) = dxint1avE(i) - dxint0(i)
            dxint1_12(i) = dxint1av12(i) - dxint0_12(i)                 
            dxint1_23(i) = dxint1av23(i) - dxint0_23(i)                 
            dxint1_13(i) = dxint1av13(i) - dxint0_13(i)                 
            dxint1_123(i) = dxint1av123(i) - dxint0_123(i)              
            dxint1_132(i) = dxint1av132(i) - dxint0_132(i)              
c
            dxint2(i) = dxint2avE(i) - dxint0(i)
            dxint2_12(i) = dxint2av12(i) - dxint0_12(i)                 
            dxint2_23(i) = dxint2av23(i) - dxint0_23(i)                 
            dxint2_13(i) = dxint2av13(i) - dxint0_13(i)                 
            dxint2_123(i) = dxint2av123(i) - dxint0_123(i)              
            dxint2_132(i) = dxint2av132(i) - dxint0_132(i)              
         if (mcihfr.ne.0) then
               do j=1,mcnics
                  kxint1(j,i) = kxint1(j,i) - kxint0(j,i)
            kxint1_12(j,i) = kxint1_12(j,i) - kxint0_12(j,i)            
            kxint1_23(j,i) = kxint1_23(j,i) - kxint0_23(j,i)            
            kxint1_13(j,i) = kxint1_13(j,i) - kxint0_13(j,i)            
            kxint1_123(j,i) = kxint1_123(j,i) - kxint0_123(j,i)         
            kxint1_132(j,i) = kxint1_132(j,i) - kxint0_132(j,i)         
                  kxint2(j,i) = kxint2(j,i) - kxint0(j,i)               
            kxint2_12(j,i) = kxint2_12(j,i) - kxint0_12(j,i)            
            kxint2_23(j,i) = kxint2_23(j,i) - kxint0_23(j,i)            
            kxint2_13(j,i) = kxint2_13(j,i) - kxint0_13(j,i)            
            kxint2_123(j,i) = kxint2_123(j,i) - kxint0_123(j,i)         
            kxint2_132(j,i) = kxint2_132(j,i) - kxint0_132(j,i)         
               enddo
         endif
         enddo
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 i=1,mcnics
            bevbm(i,mciesp) = dxint1(i)/va + dxint2(i)/vb
         enddo
         do i=1,mcnics                                                  
            bevbm_12(i,mciesp) = dxint1_12(i)/va +                      
     *                           dxint2_12(i)/vb                        
         enddo                                                          
         do i=1,mcnics                                                  
            bevbm_23(i,mciesp) = dxint1_23(i)/va +                      
     *                           dxint2_23(i)/vb                        
         enddo                                                          
         do i=1,mcnics                                                  
            bevbm_13(i,mciesp) = dxint1_13(i)/va +                      
     *                           dxint2_13(i)/vb                        
         enddo                                                          
         do i=1,mcnics                                                  
            bevbm_123(i,mciesp) = dxint1_123(i)/va +                    
     *                           dxint2_123(i)/vb                       
         enddo                                                          
         do i=1,mcnics                                                  
            bevbm_132(i,mciesp) = dxint1_132(i)/va +                    
     *                           dxint2_132(i)/vb                       
         enddo                                                          
c
         if (mcihfr.ne.0) then
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 j=1,mcnics
              do i= 1, j
                 cevbm(i,j,mciesp) = (dxint1(i)*dxint1(j))/(va*va) +
     *                               (dxint2(i)*dxint2(j))/(vb*vb) -
     *                               kxint1(i,j)/va  -
     *                               kxint2(i,j)/vb
      cevbm(j,i,mciesp) = cevbm(i,j,mciesp) 
      cevbm_12(i,j,mciesp) = (dxint1_12(i)*dxint1_12(j))/(va*va) +
     *                       (dxint2_12(i)*dxint2_12(j))/(vb*vb) -
     *                          kxint1_12(i,j)/va  -
     *                          kxint2_12(i,j)/vb
                 cevbm_12(j,i,mciesp) = cevbm_12(i,j,mciesp)
              enddo
           enddo
c
c     and mcifre=2
        else if (mcifre.eq.2)then                                      
           do j=1,mcnics                                              
              do 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
         cevbm_12(i,j,mciesp)=(dxint1_12(i)*dxint2_12(j))/(va*vb)+    
     *   (dxint2_12(i)*dxint1_12(j))/(va*vb)+      
     *   kxint1_12(i,j)/va + kxint2_12(i,j)/vb
         cevbm_23(i,j,mciesp)=(dxint1_23(i)*dxint2_23(j))/(va*vb)+
     *   (dxint2_23(i)*dxint1_23(j))/(va*vb)+
     *   kxint1_23(i,j)/va + kxint2_23(i,j)/vb
         cevbm_13(i,j,mciesp)=(dxint1_13(i)*dxint2_13(j))/(va*vb)+
     *   (dxint2_13(i)*dxint1_13(j))/(va*vb)+
     *   kxint1_13(i,j)/va + kxint2_13(i,j)/vb
         cevbm_123(i,j,mciesp)=(dxint1_123(i)*dxint2_123(j))/(va*vb)+
     *   (dxint2_123(i)*dxint1_123(j))/(va*vb)+
     *   kxint1_123(i,j)/va + kxint2_123(i,j)/vb
         cevbm_132(i,j,mciesp)=(dxint1_132(i)*dxint2_132(j))/(va*vb)+
     *   (dxint2_132(i)*dxint1_132(j))/(va*vb)+
     *   kxint1_132(i,j)/va + kxint2_132(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
              enddo
           enddo
        endif
        endif
c
c     End of the loop over the mcnesp points
c
      enddo
c
c
10      return
      end
c***********************************************************************
c     mctmmg
c***********************************************************************
c
      subroutine mctmmg
c
c     This subroutine transform the coordinates read from units 81 and 82
c     into internal coordinates. This is done after the number of electronic
c     structure theory Shepard points is read because the internal coordinates
c     are included as mcnesp+1 and mcnesp+2 entries in qs0 and qd0 arrays.
c     This transformation is made in subroutine rdk of Tinkerate.
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
      dimension dics(mcmics)
      dimension dicd(mcmicd)
      dimension xc(mcmatm),yc(mcmatm),zc(mcmatm)
c
      do k = 1, 2
c
         do i = 1, mcnatm
            xc(i) = xrc(3*i-2,k)
            yc(i) = xrc(3*i-1,k)
            zc(i) = xrc(3*i,k)
         end do
c
c     Transform molecular mechanics Shepard point 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)
         do i = 1, mcnics
            qs0(i,mcnesp+k) = dics(i)
         end do
c
c     Transform molecular mechanics Shepard point geometry into the
c     internal coordinates used for generalized distances
c
         call mctcic(mcndid,mcnand,mcnadd,mcndad,
     *               mcidid,mciand,mciadd,mcidad,
     *               mcmicd,mcmatm,xc,yc,zc,dicd)
         do i = 1, mcnicd
            qd0(i,mcnesp+k) = dicd(i)
         end do
      enddo
c
      return
      end
c***********************************************************************
c     mctmmgs
c***********************************************************************
c
      subroutine mctmmgs
c
c     This subroutine is analogous to mctmmg but for symmetrized
c     calculations. (O.T. November 2006)
c
      implicit double precision (a-h,o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      dimension dics(mcmics)
      dimension dics_12(mcmics)                                         
      dimension dics_23(mcmics)                                         
      dimension dics_13(mcmics)                                         
      dimension dics_123(mcmics)                                        
      dimension dics_132(mcmics)                                        
      dimension dicd(mcmicd)         
      dimension dicd_12(mcmicd)                                         
      dimension dicd_23(mcmicd)                                         
      dimension dicd_13(mcmicd)                                         
      dimension dicd_123(mcmicd)                                        
      dimension dicd_132(mcmicd)                                        
      dimension xii1(mcmcar)
      dimension xii2(mcmcar)
      dimension xii1_12(mcmcar)                                         
      dimension xii2_12(mcmcar)                                         
      dimension xii1_23(mcmcar)                                         
      dimension xii2_23(mcmcar)                                         
      dimension xii1_13(mcmcar)                                         
      dimension xii2_13(mcmcar)                                         
      dimension xii1_123(mcmcar)                                        
      dimension xii2_123(mcmcar)                                        
      dimension xii1_132(mcmcar)                                        
      dimension xii2_132(mcmcar)                                        
      dimension xc(mcmatm),yc(mcmatm),zc(mcmatm)
      dimension xc_12(mcmatm),yc_12(mcmatm),zc_12(mcmatm)               
      dimension xc_23(mcmatm),yc_23(mcmatm),zc_23(mcmatm)               
      dimension xc_13(mcmatm),yc_13(mcmatm),zc_13(mcmatm)               
      dimension xc_123(mcmatm),yc_123(mcmatm),zc_123(mcmatm)            
      dimension xc_132(mcmatm),yc_132(mcmatm),zc_132(mcmatm)            
      dimension xrc_12(mcmcar,2),                                       
     *          xrc_23(mcmcar,2),                                       
     *          xrc_13(mcmcar,2),                                       
     *          xrc_123(mcmcar,2),                                      
     *          xrc_132(mcmcar,2)                                       
c
         do i = 1, mcmatm
         xc(i) = 0.d0
         xc_12(i) = 0.d0
         xc_23(i) = 0.d0
         xc_13(i) = 0.d0
         xc_123(i) = 0.d0
         xc_132(i) = 0.d0
         enddo
c
         mcncar = 3*mcnatm
c
         do j = 1, mcncar
           xii1(j) = xrc(j,1)
           xii2(j) = xrc(j,2)
         enddo
         call mc12perm(xii1_12,xii1)                                    
         call mc12perm(xii2_12,xii2)                                    
           do i = 1,mcncar
            xrc_12(i,1) = xii1_12(i)                                    
            xrc_12(i,2) = xii2_12(i)                                    
           enddo                                                        
         call mc23perm(xii1_23,xii1)                                    
         call mc23perm(xii2_23,xii2)                                    
           do i = 1,mcncar
            xrc_23(i,1) = xii1_23(i)                                    
            xrc_23(i,2) = xii2_23(i)                                    
           enddo                                                        
         call mc13perm(xii1_13,xii1)                                    
         call mc13perm(xii2_13,xii2)                                    
           do i = 1,mcncar
            xrc_13(i,1) = xii1_13(i)                                    
            xrc_13(i,2) = xii2_13(i)                                    
           enddo                                                        
         call mc123perm(xii1_123,xii1)                                  
         call mc123perm(xii2_123,xii2)                                  
           do i = 1,mcncar
            xrc_123(i,1) = xii1_123(i)                                  
            xrc_123(i,2) = xii2_123(i)                                  
           enddo                                                        
         call mc132perm(xii1_132,xii1)                                  
         call mc132perm(xii2_132,xii2)                                  
           do i = 1,mcncar
            xrc_132(i,1) = xii1_132(i)                                  
            xrc_132(i,2) = xii2_132(i)                                  
           enddo                                                        
c
      do k = 1, 2
c
         do i = 1, mcnatm
            xc(i) = xrc(3*i-2,k)
            yc(i) = xrc(3*i-1,k)
            zc(i) = xrc(3*i,k)
            xc_12(i) = xrc_12(3*i-2,k)                                  
            yc_12(i) = xrc_12(3*i-1,k)                                  
            zc_12(i) = xrc_12(3*i,k)                                    
            xc_23(i) = xrc_23(3*i-2,k)                                  
            yc_23(i) = xrc_23(3*i-1,k)                                  
            zc_23(i) = xrc_23(3*i,k)                                    
            xc_13(i) = xrc_13(3*i-2,k)                                  
            yc_13(i) = xrc_13(3*i-1,k)                                  
            zc_13(i) = xrc_13(3*i,k)                                    
            xc_123(i) = xrc_123(3*i-2,k)                                
            yc_123(i) = xrc_123(3*i-1,k)                                
            zc_123(i) = xrc_123(3*i,k)                                  
            xc_132(i) = xrc_132(3*i-2,k)                                
            yc_132(i) = xrc_132(3*i-1,k)                                
            zc_132(i) = xrc_132(3*i,k)                                  
         end do
c
c     Transform molecular mechanics Shepard point 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)
         call mctcic(mcndis,mcnans,mcnads,mcndas,                       
     *               mcidis,mcians,mciads,mcidas,                       
     *               mcmics,mcmatm,xc_12,yc_12,zc_12,dics_12)           
         call mctcic(mcndis,mcnans,mcnads,mcndas,                       
     *               mcidis,mcians,mciads,mcidas,                       
     *               mcmics,mcmatm,xc_23,yc_23,zc_23,dics_23)           
         call mctcic(mcndis,mcnans,mcnads,mcndas,                       
     *               mcidis,mcians,mciads,mcidas,                       
     *               mcmics,mcmatm,xc_13,yc_13,zc_13,dics_13)           
         call mctcic(mcndis,mcnans,mcnads,mcndas,                       
     *               mcidis,mcians,mciads,mcidas,                       
     *               mcmics,mcmatm,xc_123,yc_123,zc_123,dics_123)       
         call mctcic(mcndis,mcnans,mcnads,mcndas,                       
     *               mcidis,mcians,mciads,mcidas,                       
     *               mcmics,mcmatm,xc_132,yc_132,zc_132,dics_132)       
         do i = 1, mcnics
            qs0(i,mcnesp+k) = dics(i)
            qs0_12(i,mcnesp+k) = dics_12(i)                             
            qs0_23(i,mcnesp+k) = dics_23(i)                             
            qs0_13(i,mcnesp+k) = dics_13(i)                             
            qs0_123(i,mcnesp+k) = dics_123(i)                           
            qs0_132(i,mcnesp+k) = dics_132(i)                           
          end do
c
c     Transform molecular mechanics Shepard point geometry into the
c     internal coordinates used for generalized distances
c
         call mctcic(mcndid,mcnand,mcnadd,mcndad,
     *               mcidid,mciand,mciadd,mcidad,
     *               mcmicd,mcmatm,xc,yc,zc,dicd)
         call mctcic(mcndid,mcnand,mcnadd,mcndad,                       
     *               mcidid,mciand,mciadd,mcidad,                       
     *               mcmicd,mcmatm,xc_12,yc_12,zc_12,dicd_12)           
         call mctcic(mcndid,mcnand,mcnadd,mcndad,                       
     *               mcidid,mciand,mciadd,mcidad,                       
     *               mcmicd,mcmatm,xc_23,yc_23,zc_23,dicd_23)           
         call mctcic(mcndid,mcnand,mcnadd,mcndad,                       
     *               mcidid,mciand,mciadd,mcidad,                       
     *               mcmicd,mcmatm,xc_13,yc_13,zc_13,dicd_13)           
         call mctcic(mcndid,mcnand,mcnadd,mcndad,                       
     *               mcidid,mciand,mciadd,mcidad,                       
     *               mcmicd,mcmatm,xc_123,yc_123,zc_123,dicd_123)       
         call mctcic(mcndid,mcnand,mcnadd,mcndad,                       
     *               mcidid,mciand,mciadd,mcidad,                       
     *               mcmicd,mcmatm,xc_132,yc_132,zc_132,dicd_132)       
         do i = 1, mcnicd
            qd0(i,mcnesp+k) = dicd(i)
            qd0_12(i,mcnesp+k) = dicd_12(i)                             
            qd0_23(i,mcnesp+k) = dicd_23(i)                             
            qd0_13(i,mcnesp+k) = dicd_13(i)                             
            qd0_123(i,mcnesp+k) = dicd_123(i)                           
            qd0_132(i,mcnesp+k) = dicd_132(i)                           
         end do
      enddo
c
c merge all qd0_x arrays into qd0_p12 array                                
c
         ic =0                                                          
         do k = 1, mcnesp+2                                             
               ic = ic +1                                               
           do i = 1, mcnicd                                             
             qd0_p12(i,k) = qd0(i,k)                                    
           enddo                                                        
         enddo                                                          
           ic1=ic                                                       
         do k = 1, mcnesp+2                                             
             ic1=ic1+1                                                  
           do i = 1, mcnicd                                             
             qd0_p12(i,k+ic) = qd0_12(i,k)                              
           enddo                                                        
         enddo                                                          
            ic2=ic1                                                     
         do k = 1, mcnesp+2                                             
             ic2=ic2+1                                                  
           do i = 1, mcnicd                                             
             qd0_p12(i,k+ic*2) = qd0_23(i,k)                            
           enddo                                                        
         enddo                                                          
          ic3=ic2                                                       
         do k = 1, mcnesp+2                                             
             ic3=ic3+1                                                  
           do i = 1, mcnicd                                             
             qd0_p12(i,k+ic*3) = qd0_13(i,k)                            
           enddo                                                        
         enddo                                                          
          ic4=ic3                                                       
         do k = 1, mcnesp+2                                             
             ic4=ic4+1                                                  
           do i = 1, mcnicd                                             
             qd0_p12(i,k+ic*4) = qd0_123(i,k)                           
           enddo                                                        
         enddo                                                          
          ic5=ic4                                                       
         do k = 1, mcnesp+2                                             
             ic5=ic5+1                                                  
           do i = 1, mcnicd                                             
             qd0_p12(i,k+ic*5) = qd0_132(i,k)                           
           enddo                                                        
         enddo                                                          
c
      return
      end
c***********************************************************************
c     mcv12c
c***********************************************************************
c
      subroutine mcv12c(xii,e12,g12,h12,itypec)     
c
c     This subroutine calculates the resonance function and its derivative
c     in Cartesian coordinates. It is a modified version of subroutine h12evbi
c     in Tinkerate.
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
      parameter (mcmca2=mcmcar*(mcmcar+1)/2)
      parameter (mcmic2=mcmics*(mcmics+1)/2)
      parameter (zero=0.d0)
c
      dimension xii(mcmcar)
      dimension g12(mcmcar),h12(mcmcar,mcmcar)                          
      dimension gi12(mcmics),hi12(mcmics,mcmics) 
      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
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, mcmcar
         do j = 1, mcmcar
            h12(i,j) = 0.d0
         end do
         g12(i) = 0.d0
       end do
       do i = 1, mcmics
         do j = 1, mcmics
            hi12(i,j) = 0.d0
         end do
         gi12(i)=0.d0
      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
      elseif (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
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 (ipermsym.eq.0) then
           if (icomplex.eq.1) then
              if (mcihfr.eq.0) then
                call mcv12i1st(e12,gi12,hi12,itypec)
              else
                call mcv12i(e12,gi12,hi12,itypec)
              endif
           else
             call mcv12iold(e12,gi12,hi12,itypec)
           endif
         else
           if (icomplex.eq.1) then
             if (mcihfr.eq.0) then
               call mcv12is1st(e12,gi12,hi12,itypec)
             else
               call mcv12is(e12,gi12,hi12,itypec)
             endif
           else
             call mcv12isold(e12,gi12,hi12,itypec)
           endif
         endif
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
      endif
c
c
      return
      end

c***********************************************************************
c     mcv12is1st
c***********************************************************************
c
      subroutine mcv12is1st(e12,gi12,hi12,itypec)
c
c     This subroutine is a modified version of mcv12i subroutine.
c     It returns symmetrized V12, its gradient and Hessian.
c     The formalism is described in 'Tishchenko & Truhlar, JCTC 2007, 3, 938-948'.    
c     The current version only supports systems with n = 3 identical nuclei.
c     (O.T. November 2006; modifications June 2007)
c
      implicit double precision (a-h, o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      dimension dqs(mcmics,mcmesp+2)
      dimension dqs_12(mcmics,mcmesp+2)
      dimension dqs_23(mcmics,mcmesp+2)
      dimension dqs_13(mcmics,mcmesp+2)
      dimension dqs_123(mcmics,mcmesp+2)
      dimension dqs_132(mcmics,mcmesp+2)
      dimension w_p12(mcmesp*6+12)
      dimension w(mcmesp+2)
      dimension we11(mcmesp)                                          
      dimension we11_12(mcmesp)                                       
      dimension we11_23(mcmesp)                                       
      dimension we11_13(mcmesp)                                       
      dimension we11_123(mcmesp)                                      
      dimension we11_132(mcmesp)                                      
c       dimension uterm(mcmesp)
c       dimension uterm_12(mcmesp)
c       dimension uterm_13(mcmesp)
c       dimension uterm_23(mcmesp)
c       dimension uterm_123(mcmesp)
c       dimension uterm_132(mcmesp)
c
      dimension indexw(mcmesp,6)
c
      dimension e12pnt(mcmesp),e12pf(mcmesp),e12p(mcmesp)
      dimension e12pnt_12(mcmesp),e12pf_12(mcmesp),             
     *          e12p_12(mcmesp)                                   
      dimension e12pnt_23(mcmesp),e12pf_23(mcmesp),             
     *          e12p_23(mcmesp)                                   
      dimension e12pnt_13(mcmesp),e12pf_13(mcmesp),             
     *          e12p_13(mcmesp)                                   
      dimension e12pnt_123(mcmesp),e12pf_123(mcmesp),           
     *          e12p_123(mcmesp)                                  
      dimension e12pnt_132(mcmesp),e12pf_132(mcmesp),           
     *          e12p_132(mcmesp)                                  
      dimension gi12pnt(mcmics),gi12(mcmics),hi12(mcmics,mcmics)
      dimension gi12_E(mcmics),hi12_E(mcmics,mcmics)               
      dimension gi12pnt_12(mcmics),gi12_12(mcmics),                
     * hi12_12(mcmics,mcmics)                                      
      dimension gi12pnt_23(mcmics),gi12_23(mcmics),                
     * hi12_23(mcmics,mcmics)                                      
      dimension gi12pnt_13(mcmics),gi12_13(mcmics),                
     * hi12_13(mcmics,mcmics)                                      
      dimension gi12pnt_123(mcmics),gi12_123(mcmics),              
     * hi12_123(mcmics,mcmics)                                     
      dimension gi12pnt_132(mcmics),gi12_132(mcmics),              
     * hi12_132(mcmics,mcmics)                                     
c      dimension wrk(mcmics),wrk1(mcmics)
c      dimension wrk_12(mcmics),wrk1_12(mcmics)                          
c      dimension wrk_23(mcmics),wrk1_23(mcmics)                          
c      dimension wrk_13(mcmics),wrk1_13(mcmics)                          
c      dimension wrk_123(mcmics),wrk1_123(mcmics)                        
c      dimension wrk_132(mcmics),wrk1_132(mcmics)                        
c      dimension dwf(mcmics)
      dimension  dwf(mcmesp*6+12,mcmicd)
      dimension  dwf_12(mcmesp+2,mcmicd)
      dimension  dwf_E(mcmesp+2,mcmicd)
      dimension  dwf_23(mcmesp+2,mcmicd)
      dimension  dwf_13(mcmesp+2,mcmicd)
      dimension  dwf_123(mcmesp+2,mcmicd)
      dimension  dwf_132(mcmesp+2,mcmicd)
      dimension  d2wf(mcmicd,mcmicd,mcmesp*6+12)
      dimension  d2wf_E(mcmicd,mcmicd,mcmesp+2)
      dimension  d2wf_12(mcmicd,mcmicd,mcmesp+2)
      dimension  d2wf_23(mcmicd,mcmicd,mcmesp+2)
      dimension  d2wf_13(mcmicd,mcmicd,mcmesp+2)
      dimension  d2wf_123(mcmicd,mcmicd,mcmesp+2)
      dimension  d2wf_132(mcmicd,mcmicd,mcmesp+2)
c
      zero = 0.d0
c 
c     zero out Shepard variables
c
c      do i=1,mcmics
c        do j=1,mcmesp+2
       do j=1,mcmesp+2
         do i=1,mcmics
          dqs(i,j) =  0.d0
          dqs_12(i,j) =  0.d0
          dqs_23(i,j) =  0.d0
          dqs_13(i,j) =  0.d0
          dqs_123(i,j) =  0.d0
          dqs_132(i,j) =  0.d0
        enddo
      enddo
      do i=1,mcmesp+2
      do j=1,mcmicd
      dwf_E(i,j)=0.d0
      dwf_12(i,j)=0.d0
      dwf_23(i,j)=0.d0
      dwf_13(i,j)=0.d0
      dwf_123(i,j)=0.d0
      dwf_132(i,j)=0.d0
      enddo
      enddo
      do k=1,mcmesp+2
      do i=1,mcmicd
      do j=1,mcmicd
      d2wf_E(i,j,k)=0.d0
      d2wf_12(i,j,k)=0.d0
      d2wf_23(i,j,k)=0.d0
      d2wf_13(i,j,k)=0.d0
      d2wf_123(i,j,k)=0.d0
      d2wf_132(i,j,k)=0.d0
      enddo
      enddo
      enddo
c      do i=1,mcmesp+2
      do i=1,mcmesp
        w(i)   =  0.d0
        e12pnt(i) = 0.0d0
        e12pf(i) = 0.0d0
        e12p(i) = 0.0d0
        e12pnt_12(i) = 0.0d0                                            
        e12pf_12(i) = 0.0d0                                             
        e12p_12(i) = 0.0d0                                              
        w_p12(i)   =  0.d0                                              
        e12pnt_23(i) = 0.0d0                                            
        e12pf_23(i) = 0.0d0                                             
        e12p_23(i) = 0.0d0                                              
        e12pnt_13(i) = 0.0d0                                            
        e12pf_13(i) = 0.0d0                                             
        e12p_13(i) = 0.0d0                                              
        e12pnt_123(i) = 0.0d0                                           
        e12pf_123(i) = 0.0d0                                            
        e12p_123(i) = 0.0d0                                             
        e12pnt_132(i) = 0.0d0                                           
        e12pf_132(i) = 0.0d0                                            
        e12p_132(i) = 0.0d0                                             
          do j=1,mcmics
            dwf(i,j)  = 0.d0
          enddo
      enddo       
       do i=1,mcmesp                                                    
        we11(i)=0.0d0                                                   
        we11_12(i)=0.0d0                                                
        we11_23(i)=0.0d0                                                
        we11_13(i)=0.0d0                                                
        we11_123(i)=0.0d0                                               
        we11_132(i)=0.0d0                                               
        enddo     
      do i = 1, mcmics
         do j = 1, mcmics
            hi12(i,j) = zero
            hi12_E(i,j) = zero
            hi12_12(i,j) = zero                                         
            hi12_23(i,j) = zero                                         
            hi12_13(i,j) = zero                                         
            hi12_123(i,j) = zero                                        
            hi12_132(i,j) = zero                                        
         end do
         gi12(i)=zero
         gi12_E(i)=zero                                                 
         gi12_12(i)=zero                                                
         gi12_23(i)=zero                                                
         gi12_13(i)=zero                                                
         gi12_123(i)=zero                                               
         gi12_132(i)=zero                                               
      end do
       do i=1,6
       do j=1,mcmesp
        indexw(i,j)=0
       enddo
       enddo
      do i=1,mcmics                                                     
        gi12pnt(i)  = 0.d0                                              
        gi12pnt_12(i)  = 0.d0                                           
        gi12pnt_23(i)  = 0.d0                                           
        gi12pnt_13(i)  = 0.d0                                           
        gi12pnt_123(i)  = 0.d0                                          
        gi12pnt_132(i)  = 0.d0                                          
      enddo
c
       e12 = zero
       e12_12 = zero                                                    
       e12_23 = zero                                                    
       e12_13 = zero                                                    
       e12_123 = zero                                                   
       e12_132 = zero                                                   
             e12a= zero                                                 
             e12b= zero                                                 
             e12c= zero                                                 
             e12d= zero                                                 
             e12e= zero                                                 
             e12f= zero                                                 
c
c     calculate the displacement in internal coordinates used for
c     generalized distances
c
c       qs(1)=qs(1)-0.0001d0
c       qd(1)=qd(1)-0.0001d0
c       write (*,*) "qs=", qs(1), qd(1)
c
       do j=1,mcnesp+2
         do i=1,mcnics
          dqs(i,j)=qs(i)-qs0(i,j)
          dqs_12(i,j)=qs(i)-qs0_12(i,j)                                 
          dqs_23(i,j)=qs(i)-qs0_23(i,j)                                 
          dqs_13(i,j)=qs(i)-qs0_13(i,j)                                 
          dqs_123(i,j)=qs(i)-qs0_123(i,j)                               
          dqs_132(i,j)=qs(i)-qs0_132(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
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas                 
               if (dqs_12(i,j).lt.-fpi) then                            
                   dqs_12(i,j) = dqs_12(i,j)+2.0d0*fpi                  
               elseif (dqs_12(i,j).gt.fpi) then                         
                   dqs_12(i,j) = dqs_12(i,j)-2.0d0*fpi                  
               endif                                                    
            enddo                                                       
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas                 
               if (dqs_23(i,j).lt.-fpi) then                            
                   dqs_23(i,j) = dqs_23(i,j)+2.0d0*fpi                  
               elseif (dqs_23(i,j).gt.fpi) then                         
                   dqs_23(i,j) = dqs_23(i,j)-2.0d0*fpi                  
               endif                                                    
            enddo                                                       
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas                 
               if (dqs_13(i,j).lt.-fpi) then                            
                   dqs_13(i,j) = dqs_13(i,j)+2.0d0*fpi                  
               elseif (dqs_13(i,j).gt.fpi) then                         
                   dqs_13(i,j) = dqs_13(i,j)-2.0d0*fpi                  
               endif                                                    
            enddo                                                       
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas                 
               if (dqs_123(i,j).lt.-fpi) then                           
                   dqs_123(i,j) = dqs_123(i,j)+2.0d0*fpi                
               elseif (dqs_123(i,j).gt.fpi) then                        
                   dqs_123(i,j) = dqs_123(i,j)-2.0d0*fpi                
               endif                                                    
            enddo                                                       
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas                 
               if (dqs_132(i,j).lt.-fpi) then                           
                   dqs_132(i,j) = dqs_132(i,j)+2.0d0*fpi                
               elseif (dqs_132(i,j).gt.fpi) then                        
                   dqs_132(i,j) = dqs_132(i,j)-2.0d0*fpi                
               endif                                                    
            enddo                                                       
         endif
      enddo
c
c get weights
c
       call mcswtsnum(w_p12,dwf,d2wf,itypec)
c
          j = 0
c
c  loop over all (m!N) Shepard points to select weights+derivatives for the ES points
c  and leave out the data for MM structures 1 and 2.                      
           k=2                                                          
c                                                                       
           do i=0,5                                                     
           do j=1,mcnesp                                                
           indexw(j,i+1)=mcnesp*i+k*i+j                                 
           enddo                                                        
           enddo                                                        
c                                                                       
          do j = 1, mcnesp                                              
          we11(j)=w_p12(indexw(j,1))                                    
          do i=1,mcnicd
          dwf_E(j,i)=dwf(indexw(j,1),i)
          do k=1,mcnicd
          d2wf_E(i,k,j)=d2wf(i,k,indexw(j,1))
          enddo
          enddo
c          dw11(j)=dw_p12(indexw(j,1))                                  
c          ddw1_E(j)=ddw1_p12(indexw(j,1))                              
c          ddw2_E(j)=ddw2_p12(indexw(j,1))                              
          enddo                                                         
          do j = 1, mcnesp                                              
          we11_12(j)=w_p12(indexw(j,2))                                 
          do i=1,mcnicd
          dwf_12(j,i)=dwf(indexw(j,2),i)
          do k=1,mcnicd
          d2wf_12(i,k,j)=d2wf(i,k,indexw(j,2))
          enddo
          enddo
c          dw11_12(j)=dw_p12(indexw(j,2))                              
c          ddw1_12(j)=ddw1_p12(indexw(j,2))                            
c          ddw2_12(j)=ddw2_p12(indexw(j,2))                            
          enddo                                                        
          do j = 1, mcnesp                                             
          we11_23(j)=w_p12(indexw(j,3))                                
          do i=1,mcnicd
          dwf_23(j,i)=dwf(indexw(j,3),i)
          do k=1,mcnicd
          d2wf_23(i,k,j)=d2wf(i,k,indexw(j,3))
          enddo
          enddo
c          dw11_23(j)=dw_p12(indexw(j,3))                              
c          ddw1_23(j)=ddw1_p12(indexw(j,3))                             
c          ddw2_23(j)=ddw2_p12(indexw(j,3))                            
          enddo                                                        
          do j = 1, mcnesp                                             
          we11_13(j)=w_p12(indexw(j,4))                                
          do i=1,mcnicd
          dwf_13(j,i)=dwf(indexw(j,4),i)
          do k=1,mcnicd
          d2wf_13(i,k,j)=d2wf(i,k,indexw(j,4))
          enddo
          enddo
c          dw11_13(j)=dw_p12(indexw(j,4))                             
c          ddw1_13(j)=ddw1_p12(indexw(j,4))                           
c          ddw2_13(j)=ddw2_p12(indexw(j,4))                           
          enddo                                                       
          do j = 1, mcnesp                                            
          we11_123(j)=w_p12(indexw(j,5))                              
          do i=1,mcnicd
          dwf_123(j,i)=dwf(indexw(j,5),i)
          do k=1,mcnicd
          d2wf_123(i,k,j)=d2wf(i,k,indexw(j,5))
          enddo
          enddo
c          dw11_123(j)=dw_p12(indexw(j,5))                             
c          ddw1_123(j)=ddw1_p12(indexw(j,5))                           
c          ddw2_123(j)=ddw2_p12(indexw(j,5))                           
          enddo                                                        
          do j = 1, mcnesp                                             
          we11_132(j)=w_p12(indexw(j,6))                               
          do i=1,mcnicd
          dwf_132(j,i)=dwf(indexw(j,6),i)
          do k=1,mcnicd
          d2wf_132(i,k,j)=d2wf(i,k,indexw(j,6))
          enddo
          enddo
c          dw11_132(j)=dw_p12(indexw(j,6))                            
c          ddw1_132(j)=ddw1_p12(indexw(j,6))                          
c          ddw2_132(j)=ddw2_p12(indexw(j,6))                          
          enddo                                                       
          do j = 1, mcnesp                                            
          enddo  
c          
       do 1000 mciesp=1,mcnesp                                                           
c
          btrm=0.d0
          ctrm=0.d0
          qtrm=0.d0
          btrm_12=0.d0                                                  
          btrm_23=0.d0                                                  
          btrm_13=0.d0                                                  
          btrm_123=0.d0                                                 
          btrm_132=0.d0                                                 
          ctrm_12=0.d0                                                  
          ctrm_23=0.d0                                                  
          ctrm_13=0.d0                                                  
          ctrm_123=0.d0                                                 
          ctrm_132=0.d0                                                 
          qtrm_12=0.d0                                                  
          be12=0.d0                                                     
          be12_12=0.d0                                                  
          be12_23=0.d0                                                  
          be12_13=0.d0                                                  
          be12_123=0.d0                                                 
          be12_132=0.d0                                                 
c
          do i=1,mcnics
c            wrk(i) =0.d0
c            wrk_12(i) =0.d0                                             
c            wrk_23(i) =0.d0                                             
c            wrk_13(i) =0.d0                                             
c            wrk_123(i) =0.d0                                            
c            wrk_132(i) =0.d0                                            
            btrm=btrm+bevbm(i,mciesp)*dqs(i,mciesp)                     
            btrm_12=btrm_12+bevbm_12(i,mciesp)*dqs_12(i,mciesp)          
            btrm_23=btrm_23+bevbm_23(i,mciesp)*dqs_23(i,mciesp)         
            btrm_13=btrm_13+bevbm_13(i,mciesp)*dqs_13(i,mciesp)         
            btrm_123=btrm_123+bevbm_123(i,mciesp)*dqs_123(i,mciesp)     
            btrm_132=btrm_132+bevbm_132(i,mciesp)*dqs_132(i,mciesp)     
c            do j=1,mcnics
c              wrk(i)=wrk(i)+dqs(j,mciesp)*cevbm(i,j,mciesp)
c          wrk_12(i)=wrk_12(i)+dqs_12(j,mciesp)*cevbm_12(i,j,mciesp)     
c          wrk_23(i)=wrk_23(i)+dqs_23(j,mciesp)*cevbm_23(i,j,mciesp)     
c          wrk_13(i)=wrk_13(i)+dqs_13(j,mciesp)*cevbm_13(i,j,mciesp)     
c          wrk_123(i)=wrk_123(i)+dqs_123(j,mciesp)*cevbm_123(i,j,mciesp) 
c          wrk_132(i)=wrk_132(i)+dqs_132(j,mciesp)*cevbm_132(i,j,mciesp) 
c            enddo
c            ctrm=ctrm+dqs(i,mciesp)*wrk(i)
c            ctrm_12=ctrm_12+dqs_12(i,mciesp)*wrk_12(i)                  
c            ctrm_23=ctrm_23+dqs_23(i,mciesp)*wrk_23(i)                  
c            ctrm_13=ctrm_13+dqs_13(i,mciesp)*wrk_13(i)                  
c            ctrm_123=ctrm_123+dqs_123(i,mciesp)*wrk_123(i)              
c            ctrm_132=ctrm_132+dqs_132(i,mciesp)*wrk_132(i)              
          enddo
c
          be12 = 1.d0+btrm
          be12_12 = 1.d0+btrm_12
          be12_23 = 1.d0+btrm_23
          be12_13 = 1.d0+btrm_13
          be12_123 = 1.d0+btrm_123
          be12_132 = 1.d0+btrm_132
          e12p(mciesp) = aevbm(mciesp)*be12
          e12p_12(mciesp) = aevbm(mciesp)*be12_12                       
          e12p_23(mciesp) = aevbm(mciesp)*be12_23                       
          e12p_13(mciesp) = aevbm(mciesp)*be12_13                       
          e12p_123(mciesp) = aevbm(mciesp)*be12_123                     
          e12p_132(mciesp) = aevbm(mciesp)*be12_132                     
c
        e12a = e12a+we11(mciesp)*e12p(mciesp)        
        e12b = e12b+we11_12(mciesp)*e12p_12(mciesp)    
        e12c = e12c+we11_23(mciesp)*e12p_23(mciesp)     
        e12d = e12d+we11_13(mciesp)*e12p_13(mciesp)     
        e12e = e12e+we11_123(mciesp)*e12p_123(mciesp)     
        e12f = e12f+we11_132(mciesp)*e12p_132(mciesp)     
        e12 = e12a + e12b + e12c + e12d + e12e +e12f
c
c------------------end of e12------------------------------------
c
c------------------ begin calculating the first derivatives -----
c
c     first check if it is necessary (itypec >= 1)
c
c          itypec=2
          if (itypec .eq. 1) goto 1000
c          do k=1,mcnics
c            wrk1s = 0.d0
c            wrk1s_12 = 0.d0                                             
c            wrk1s_23 = 0.d0                                             
c            wrk1s_13 = 0.d0                                             
c            wrk1s_123 = 0.d0                                            
c            wrk1s_132 = 0.d0                                            
c              do k1 = 1,mcnics                                          
c                wrk1s = wrk1s+cevbm(k1,k,mciesp)*dqs(k1,mciesp)
c                wrk1s_12 = wrk1s_12+                                    
c     *    cevbm_12(k1,k,mciesp)*dqs_12(k1,mciesp)                       
c                wrk1s_23 = wrk1s_23+                                    
c     *    cevbm_23(k1,k,mciesp)*dqs_23(k1,mciesp)                       
c                wrk1s_13 = wrk1s_13+                                    
c     *    cevbm_13(k1,k,mciesp)*dqs_13(k1,mciesp)                       
c                wrk1s_123 = wrk1s_123+                                  
c     *    cevbm_123(k1,k,mciesp)*dqs_123(k1,mciesp)                     
c                wrk1s_132 = wrk1s_132+                                  
c     *    cevbm_132(k1,k,mciesp)*dqs_132(k1,mciesp)                     
c              enddo                                                     
c            wrk1(k) = wrk1s                                             
c            wrk1_12(k) = wrk1s_12                                       
c            wrk1_23(k) = wrk1s_23                                       
c            wrk1_13(k) = wrk1s_13                                       
c            wrk1_123(k) = wrk1s_123                                     
c            wrk1_132(k) = wrk1s_132                                     
c          enddo                                                         
          do k=1,mcnics                                                 
                gi12pnt(k)=aevbm(mciesp)*bevbm(k,mciesp)
c
                gi12pnt_12(k)=aevbm(mciesp)*bevbm_12(k,mciesp)
c
                gi12pnt_23(k)=aevbm(mciesp)*bevbm_23(k,mciesp)
c
                gi12pnt_13(k)=aevbm(mciesp)*bevbm_13(k,mciesp)
c
                gi12pnt_123(k)=aevbm(mciesp)*bevbm_123(k,mciesp)
c
                gi12pnt_132(k)=aevbm(mciesp)*bevbm_132(k,mciesp)
c                                                                       
          enddo
c                                                                       
c     weight the gradient                                               
c                                                                       
          do k=1,mcnics                                                 
            gi12_E(k) = gi12_E(k) + gi12pnt(k)*we11(mciesp)
            gi12_12(k) = gi12_12(k) +                                  
     *     gi12pnt_12(k)*we11_12(mciesp)
           gi12_23(k) = gi12_23(k) +                                   
     *     gi12pnt_23(k)*we11_23(mciesp)
           gi12_13(k) = gi12_13(k) +                                   
     *     gi12pnt_13(k)*we11_13(mciesp)
           gi12_123(k) = gi12_123(k) +                                 
     *     gi12pnt_123(k)*we11_123(mciesp)
           gi12_132(k) = gi12_132(k) +                                 
     *     gi12pnt_132(k)*we11_132(mciesp)
c           write (*,*) "gi12",gi12_E(k),gi12_12(k),gi12_23(k),
c     *     gi12_13(k),gi12_123(k),gi12_132(k),k
c           write (*,*) "gi12",gi12_13(k),gi12pnt_13(k),we11_13(mciesp)
c            write (*,*) "gi12pnt(k)",gi12pnt(k),gi12pnt_12(k),
c     *    gi12pnt_23(k),gi12pnt_13(k),gi12pnt_123(k),gi12pnt_132(k),k
          enddo
c            do k=1,mcnics
c         gi12(k)=gi12_E(k)+gi12_12(k)+gi12_23(k)+
c     &   gi12_13(k)+gi12_123(k)+gi12_132(k)  
c            enddo
c 
c     if shepard interpolation is used, calculate dwf(k)=dW(i)/dqs(k)
c
        if (mcimre.eq.2) then
        do k=1,mcnicb
              kw=mciicb(k)
cccc        gi12_E(kw)=gi12_E(kw)+e12pnt(mciesp)*dwf_E(mciesp,kw)
        gi12_E(kw)=gi12_E(kw)+e12p(mciesp)*dwf_E(mciesp,kw)
c
cccc        gi12_12(kw)=gi12_12(kw)+e12pnt_12(mciesp)*dwf_12(mciesp,kw)            
        gi12_12(kw)=gi12_12(kw)+e12p_12(mciesp)*dwf_12(mciesp,kw)
c              
cccc        gi12_23(kw)=gi12_23(kw)+e12pnt_23(mciesp)*dwf_23(mciesp,kw)           
        gi12_23(kw)=gi12_23(kw)+e12p_23(mciesp)*dwf_23(mciesp,kw)
c               
cccc        gi12_13(kw)=gi12_13(kw)+e12pnt_13(mciesp)*dwf_13(mciesp,kw)          
        gi12_13(kw)=gi12_13(kw)+e12p_13(mciesp)*dwf_13(mciesp,kw)
c               
cccc        gi12_123(kw)=gi12_123(kw)+
cccc     &   e12pnt_123(mciesp)*dwf_123(mciesp,kw)   
        gi12_123(kw)=gi12_123(kw)+
     &   e12p_123(mciesp)*dwf_123(mciesp,kw)
c               
cccc        gi12_132(kw)=gi12_132(kw)+
cccc     &   e12pnt_132(mciesp)*dwf_132(mciesp,kw)
        gi12_132(kw)=gi12_132(kw)+
     &   e12p_132(mciesp)*dwf_132(mciesp,kw)
c              
        enddo
        do k=1,mcnics
         gi12(k)=gi12_E(k)+gi12_12(k)+gi12_23(k)+
     &   gi12_13(k)+gi12_123(k)+gi12_132(k)  
        enddo
        endif
c
c----------------- end of first derivative calculations ------
c
c------------------ begin calculating the hessian -----
c
c     first check if it is necessary (itypec = 1)
c
          if (itypec .eq. 2) goto 1000
c
c   1. calculate dd(e12(i))/(dqs(k)dqs(s))*w(i)
c
cc          if (e12p(mciesp).gt.0.0) then
            do ik=1,mcnics
              do is=ik,mcnics
c                hi12_E(is,ik)=hi12_E(is,ik)+(-gi12pnt(is)*gi12pnt(ik)+
c     *           0.5d0*(aevbm(mciesp)*fixf*0.5d0*(cevbm(is,ik,mciesp)+
c     *                  cevbm(ik,is,mciesp))+delta*delta*fixf*
c     *                (bevbm(is,mciesp)+0.5d0*(wrk(is)+wrk1(is)))*
c     *                 (bevbm(ik,mciesp)+0.5d0*(wrk(ik)+wrk1(ik)))/    
c     *            (aevbm(mciesp)*be12**3)+0.5d0*(cevbm(is,ik,mciesp)+
c     *                   cevbm(ik,is,mciesp))*delta*fixf/be12))
c     *                    /e12pnt(mciesp)*we11(mciesp)
c
cc               hi12_E(is,ik)=hi12_E(is,ik)+(-gi12pnt(is)*gi12pnt(ik)+         0612OT08
cc     *          aevbm(mciesp)*aevbm(mciesp)*unn*unn*fixf*fixf*                   0612OT08
cc     *          (bevbm(is,mciesp)+0.5d0*(wrk(is)+wrk1(is)))*                   0612OT08
cc     *          (bevbm(ik,mciesp)+                                             0612OT08
cc     *          0.5d0*(wrk(ik)+wrk1(ik)))/e12p(mciesp)*                        0612OT08
cc     *      uterm(mciesp)**unn*(unn*fixf*uterm(mciesp)**unn-unn+1.d0)+         0612OT08
cc     *          0.5d0*aevbm(mciesp)*0.5d0*(cevbm(is,ik,mciesp)+                0612OT08
cc     *        cevbm(ik,is,mciesp))*fixf*(unn*fixf*uterm(mciesp)**unn+          0612OT08
cc     *          1.d0))/e12pnt(mciesp)*we11(mciesp)                             0612OT08
cc                hi12_E(ik,is)=hi12_E(is,ik)              
                  hi12_E(is,ik)=hi12_E(is,ik)+aevbm(mciesp)*
     *            0.5d0*(cevbm(is,ik,mciesp)+
     *            cevbm(ik,is,mciesp))*we11(mciesp)
                  hi12_E(ik,is)=hi12_E(is,ik)
              enddo
            enddo
cc          endif
c
cc          if (e12p_12(mciesp).gt.0.0) then                              
            do ik=1,mcnics                                              
              do is=ik,mcnics                                           
c         hi12_12(is,ik)=hi12_12(is,ik)+
c     *   (-gi12pnt_12(is)*gi12pnt_12(ik)+
c     *   0.5d0*(aevbm(mciesp)*fixf_12*0.5d0*(cevbm_12(is,ik,mciesp)+    
c     *   cevbm_12(ik,is,mciesp))+delta*delta*fixf_12*                   
c     *   (bevbm_12(is,mciesp)+0.5d0*(wrk_12(is)+wrk1_12(is)))*          
c     *   (bevbm_12(ik,mciesp)+0.5d0*(wrk_12(ik)+wrk1_12(ik)))/          
c     *   (aevbm(mciesp)*be12_12**3)+0.5d0*(cevbm_12(is,ik,mciesp)+      
c     *   cevbm_12(ik,is,mciesp))*delta*fixf_12/be12_12))                
c     *   /e12pnt_12(mciesp)*we11_12(mciesp)
cc          hi12_12(is,ik)=hi12_12(is,ik)+
cc     *    (-gi12pnt_12(is)*gi12pnt_12(ik)+                                        0612OT08
cc     *    aevbm(mciesp)*aevbm(mciesp)*unn*unn*fixf_12*fixf_12*                      0612OT08
cc     *    (bevbm_12(is,mciesp)+0.5d0*(wrk_12(is)+wrk1_12(is)))*                   0612OT08
cc     *    (bevbm_12(ik,mciesp)+                                                   0612OT08
cc     *    0.5d0*(wrk_12(ik)+wrk1_12(ik)))/e12p_12(mciesp)*                        0612OT08
cc     *    uterm_12(mciesp)**unn*(unn*fixf_12*uterm_12(mciesp)**unn-unn                0612OT08
cc     *    +1.d0)+                                                                 0612OT08
cc     *    0.5d0*aevbm(mciesp)*0.5d0*(cevbm_12(is,ik,mciesp)+                      0612OT08
cc     *    cevbm_12(ik,is,mciesp))*                                                0612OT08
cc     *    fixf_12*(unn*fixf_12*uterm_12(mciesp)**unn+                               0612OT08
cc     *    1.d0))/e12pnt_12(mciesp)*we11_12(mciesp)                                0612OT08
cc          hi12_12(ik,is)=hi12_12(is,ik)                                           
                  hi12_12(is,ik)=hi12_12(is,ik)+aevbm(mciesp)*
     *            0.5d0*(cevbm_12(is,ik,mciesp)+
     *            cevbm_12(ik,is,mciesp))*we11_12(mciesp)
                  hi12_12(ik,is)=hi12_12(is,ik)
              enddo                                                     
            enddo                                                       
cc          endif                                                         
c                                                                       
cc          if (e12p_23(mciesp).gt.0.0) then                              
            do ik=1,mcnics                                              
              do is=ik,mcnics                                           
c          hi12_23(is,ik)=hi12_23(is,ik)+
c     *    (-gi12pnt_23(is)*gi12pnt_23(ik)+
c     *    0.5d0*(aevbm(mciesp)*fixf_23*0.5d0*(cevbm_23(is,ik,mciesp)+   
c     *    cevbm_23(ik,is,mciesp))+delta*delta*fixf_23*                  
c     *    (bevbm_23(is,mciesp)+0.5d0*(wrk_23(is)+wrk1_23(is)))*         
c     *    (bevbm_23(ik,mciesp)+0.5d0*(wrk_23(ik)+wrk1_23(ik)))/         
c     *    (aevbm(mciesp)*be12_23**3)+0.5d0*(cevbm_23(is,ik,mciesp)+     
c     *    cevbm_23(ik,is,mciesp))*delta*fixf_23/be12_23))               
c     *    /e12pnt_23(mciesp)*we11_23(mciesp)
cc          hi12_23(is,ik)=hi12_23(is,ik)+
cc     *    (-gi12pnt_23(is)*gi12pnt_23(ik)+                                        0612OT08
cc     *    aevbm(mciesp)*aevbm(mciesp)*unn*unn*fixf_23*fixf_23*                      0612OT08
cc     *    (bevbm_23(is,mciesp)+0.5d0*(wrk_23(is)+wrk1_23(is)))*                   0612OT08
cc     *    (bevbm_23(ik,mciesp)+                                                   0612OT08
cc     *    0.5d0*(wrk_23(ik)+wrk1_23(ik)))/e12p_23(mciesp)*                        0612OT08
cc     *    uterm_23(mciesp)**unn*(unn*fixf_23*uterm_23(mciesp)**unn-unn                0612OT08
cc     *    +1.d0)+                                                                 0612OT08
cc     *    0.5d0*aevbm(mciesp)*0.5d0*(cevbm_23(is,ik,mciesp)+                      0612OT08
cc     *    cevbm_23(ik,is,mciesp))*                                                0612OT08
cc    *    fixf_23*(unn*fixf_23*uterm_23(mciesp)**unn+                               0612OT08
cc     *    1.d0))/e12pnt_23(mciesp)*we11_23(mciesp)                                0612OT08
cc                hi12_23(ik,is)=hi12_23(is,ik)                                     
                  hi12_23(is,ik)=hi12_23(is,ik)+aevbm(mciesp)*
     *            0.5d0*(cevbm_23(is,ik,mciesp)+
     *            cevbm_23(ik,is,mciesp))*we11_23(mciesp)
                  hi12_23(ik,is)=hi12_23(is,ik)
              enddo                                                     
            enddo                                                       
cc          endif                                                         
c                                                                       
cc          if (e12p_13(mciesp).gt.0.0) then                              
            do ik=1,mcnics                                              
              do is=ik,mcnics                                           
c          hi12_13(is,ik)=hi12_13(is,ik)+
c     *    (-gi12pnt_13(is)*gi12pnt_13(ik)+
c     *    0.5d0*(aevbm(mciesp)*fixf_13*0.5d0*(cevbm_13(is,ik,mciesp)+   
c     *    cevbm_13(ik,is,mciesp))+delta*delta*fixf_13*                  
c     *    (bevbm_13(is,mciesp)+0.5d0*(wrk_13(is)+wrk1_13(is)))*         
c     *    (bevbm_13(ik,mciesp)+0.5d0*(wrk_13(ik)+wrk1_13(ik)))/         
c     *    (aevbm(mciesp)*be12_13**3)+0.5d0*(cevbm_13(is,ik,mciesp)+     
c     *    cevbm_13(ik,is,mciesp))*delta*fixf_13/be12_13))               
c     *    /e12pnt_13(mciesp)*we11_13(mciesp)
cc          hi12_13(is,ik)=hi12_13(is,ik)+
cc     *    (-gi12pnt_13(is)*gi12pnt_13(ik)+                                        0612OT08
cc     *    aevbm(mciesp)*aevbm(mciesp)*unn*unn*fixf_13*fixf_13*                      0612OT08
cc     *    (bevbm_13(is,mciesp)+0.5d0*(wrk_13(is)+wrk1_13(is)))*                   0612OT08
cc     *    (bevbm_13(ik,mciesp)+                                                   0612OT08
cc     *    0.5d0*(wrk_13(ik)+wrk1_13(ik)))/e12p_13(mciesp)*                        0612OT08
cc     *    uterm_13(mciesp)**unn*(unn*fixf_13*uterm_13(mciesp)**unn-unn                0612OT08
cc     *    +1.d0)+                                                                 0612OT08
cc     *    0.5d0*aevbm(mciesp)*0.5d0*(cevbm_13(is,ik,mciesp)+                      0612OT08
cc     *    cevbm_13(ik,is,mciesp))*                                                0612OT08
cc     *    fixf_13*(unn*fixf_13*uterm_13(mciesp)**unn+                               0612OT08
cc     *    1.d0))/e12pnt_13(mciesp)*we11_13(mciesp)                                0612OT08
cc                hi12_13(ik,is)=hi12_13(is,ik)                                     
                  hi12_13(is,ik)=hi12_13(is,ik)+aevbm(mciesp)*
     *            0.5d0*(cevbm_13(is,ik,mciesp)+
     *            cevbm_13(ik,is,mciesp))*we11_13(mciesp)
                  hi12_13(ik,is)=hi12_13(is,ik)
              enddo                                                     
            enddo                                                       
cc          endif                                                         
c                                                                       
cc          if (e12p_123(mciesp).gt.0.0) then                             
            do ik=1,mcnics                                              
              do is=ik,mcnics                                           
c        hi12_123(is,ik)=hi12_123(is,ik)+(-gi12pnt_123(is)*              
c     *  gi12pnt_123(ik)+                                                
c     *  0.5d0*(aevbm(mciesp)*fixf_123*0.5d0*(cevbm_123(is,ik,mciesp)+   
c     *  cevbm_123(ik,is,mciesp))+delta*delta*fixf_123*                  
c     *  (bevbm_123(is,mciesp)+0.5d0*(wrk_123(is)+wrk1_123(is)))*        
c     *  (bevbm_123(ik,mciesp)+0.5d0*(wrk_123(ik)+wrk1_123(ik)))/        
c     *  (aevbm(mciesp)*be12_123**3)+0.5d0*(cevbm_123(is,ik,mciesp)+     
c     *  cevbm_123(ik,is,mciesp))*delta*fixf_123/be12_123))              
c     *  /e12pnt_123(mciesp)*we11_123(mciesp)
cc          hi12_123(is,ik)=hi12_123(is,ik)+
cc     *    (-gi12pnt_123(is)*gi12pnt_123(ik)+                                       0612OT08
cc     *    aevbm(mciesp)*aevbm(mciesp)*unn*unn*fixf_123*fixf_123*                     0612OT08
cc     *    (bevbm_123(is,mciesp)+0.5d0*(wrk_123(is)+wrk1_123(is)))*                 0612OT08
cc     *    (bevbm_123(ik,mciesp)+                                                   0612OT08
cc     *    0.5d0*(wrk_123(ik)+wrk1_123(ik)))/e12p_123(mciesp)*                      0612OT08
cc     * uterm_123(mciesp)**unn*(unn*fixf_123*uterm_123(mciesp)**unn-unn              0612OT08
cc     *    +1.d0)+                                                                  0612OT08
cc     *    0.5d0*aevbm(mciesp)*0.5d0*(cevbm_123(is,ik,mciesp)+                      0612OT08
cc     *    cevbm_123(ik,is,mciesp))*                                                0612OT08
cc     *    fixf_123*(unn*fixf_123*uterm_123(mciesp)**unn+                             0612OT08
cc     *    1.d0))/e12pnt_123(mciesp)*we11_123(mciesp)                               0612OT08
cc               hi12_123(ik,is)=hi12_123(is,ik)                         
                  hi12_123(is,ik)=hi12_123(is,ik)+aevbm(mciesp)*
     *            0.5d0*(cevbm_123(is,ik,mciesp)+
     *            cevbm_123(ik,is,mciesp))*we11_123(mciesp)
                  hi12_123(ik,is)=hi12_123(is,ik)
              enddo                                                     
            enddo                                                       
cc          endif                                                         
c                                                                       
cc          if (e12p_132(mciesp).gt.0.0) then                             
            do ik=1,mcnics                                              
              do is=ik,mcnics                                           
c         hi12_132(is,ik)=hi12_132(is,ik)+(-gi12pnt_132(is)*             
c     *   gi12pnt_132(ik)+                                               
c     *   0.5d0*(aevbm(mciesp)*fixf_132*0.5d0*(cevbm_132(is,ik,mciesp)+  
c     *   cevbm_132(ik,is,mciesp))+delta*delta*fixf_132*                 
c     *   (bevbm_132(is,mciesp)+0.5d0*(wrk_132(is)+wrk1_132(is)))*       
c     *   (bevbm_132(ik,mciesp)+0.5d0*(wrk_132(ik)+wrk1_132(ik)))/       
c     *   (aevbm(mciesp)*be12_132**3)+0.5d0*(cevbm_132(is,ik,mciesp)+    
c     *   cevbm_132(ik,is,mciesp))*delta*fixf_132/be12_132))             
c     *   /e12pnt_132(mciesp)*we11_132(mciesp)
cc          hi12_132(is,ik)=hi12_132(is,ik)+
cc     *    (-gi12pnt_132(is)*gi12pnt_132(ik)+
cc     *    aevbm(mciesp)*aevbm(mciesp)*unn*unn*fixf_132*fixf_132*                      0612OT08
cc     *    (bevbm_132(is,mciesp)+0.5d0*(wrk_132(is)+wrk1_132(is)))*                  0612OT08
cc     *    (bevbm_132(ik,mciesp)+                                                    0612OT08
cc    *    0.5d0*(wrk_132(ik)+wrk1_132(ik)))/e12p_132(mciesp)*                       0612OT08
cc     * uterm_132(mciesp)**unn*(unn*fixf_132*uterm_132(mciesp)**unn-unn               0612OT08
cc     *    +1.d0)+                                                                   0612OT08
cc     *    0.5d0*aevbm(mciesp)*0.5d0*(cevbm_132(is,ik,mciesp)+                       0612OT08
cc     *    cevbm_132(ik,is,mciesp))*                                                 0612OT08
cc     *    fixf_132*(unn*fixf_132*uterm_132(mciesp)**unn+                              0612OT08
cc     *    1.d0))/e12pnt_132(mciesp)*we11_132(mciesp)                                0612OT08
cc                hi12_132(ik,is)=hi12_132(is,ik)                                    
                  hi12_132(is,ik)=hi12_132(is,ik)+aevbm(mciesp)*
     *            0.5d0*(cevbm_132(is,ik,mciesp)+
     *            cevbm_132(ik,is,mciesp))*we11_132(mciesp)
                  hi12_132(ik,is)=hi12_132(is,ik)
              enddo                                                     
            enddo                                                       
cc          endif                                                         
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                                         
c            ddwf2_E = ddw2_E(mciesp)/wsum_p12-                              
c     *   we11(mciesp)*sddw2/(wsum_p12*wsum_p12)                         
            do ik=1,mcnicb                                              
              iwk=mciicb(ik)                                            
c              detqk=dqs(iwk,mciesp)                                     
              do is=ik,mcnicb                                           
                iws=mciicb(is)                                          
c                detqs=dqs(iws,mciesp)                                   
c                d2wf_E=(ddw1_E(mciesp)*detqk*detqs*wsum_p12               
c     *              -dw11(mciesp)*detqk*sdw(is)                         
c     *              -we11(mciesp)*sddw1(is,ik)                          
c     *              -dw11(mciesp)*detqs*sdw(ik)                           
c     *              +2.d0*we11(mciesp)*sdw(ik)*
c     *               sdw(is)/wsum_p12)/(wsum_p12**2)  
c                if(iws .eq. iwk)d2wf_E=d2wf_E+ddwf2_E                         
                hi12_E(iws,iwk)=hi12_E(iws,iwk)+
     *          d2wf_E(iws,iwk,mciesp)*e12p(mciesp)         
                hi12_E(iwk,iws)=hi12_E(iws,iwk)                             
              enddo        
c                                                                       
c   3. calculate cross terms                                            
c                                                                       
              do j=1,mcnics                                             
c                hi12_E(iwk,j)=hi12_E(iwk,j)+dwf(ik)*gi12pnt(j)              
c                hi12_E(j,iwk)=hi12_E(j,iwk)+dwf(ik)*gi12pnt(j)              
                hi12_E(iwk,j)=hi12_E(iwk,j)+
     *          dwf_E(mciesp,iwk)*gi12pnt(j)
                hi12_E(j,iwk)=hi12_E(j,iwk)+
     *          dwf_E(mciesp,iwk)*gi12pnt(j)
              enddo                                                     
             enddo                                                      
c                                                                       
c            ddwf2_12 = ddw2_12(mciesp)/wsum_p12-                      
c     *  we11_12(mciesp)*sddw2_12/(wsum_p12*wsum_p12)                  
            do ik=1,mcnicb                                             
              iwk=mciicb(ik)                                           
              detqk_12=dqs_12(iwk,mciesp)                              
              do is=ik,mcnicb                                          
                iws=mciicb(is)                                         
                detqs_12=dqs_12(iws,mciesp)                            
c        d2wf_12=(ddw1_12(mciesp)*detqk_12*detqs_12*wsum_p12           
c     *  -dw11_12(mciesp)*detqk_12*sdw_12(is)                          
c     *  -we11_12(mciesp)*sddw1_12(is,ik)                              
c     *  -dw11_12(mciesp)*detqs_12*sdw_12(ik)                          
c     *  +2.d0*we11_12(mciesp)*sdw_12(ik)*                             
c     *  sdw_12(is)/wsum_p12)/(wsum_p12**2)                            
c        if(iws .eq. iwk)d2wf_12=d2wf_12+ddwf2_12                      
        hi12_12(iws,iwk)=hi12_12(iws,iwk)+
     *  d2wf_12(iws,iwk,mciesp)*e12p_12(mciesp)  
        hi12_12(iwk,iws)=hi12_12(iws,iwk)                              
              enddo                                                    
c                                                                      
c   3. calculate cross terms                                           
c                                                                      
       do j=1,mcnics                                                   
c         hi12_12(iwk,j)=hi12_12(iwk,j)+dwf_12(ik)*gi12pnt_12(j)       
c         hi12_12(j,iwk)=hi12_12(j,iwk)+dwf_12(ik)*gi12pnt_12(j)       
         hi12_12(iwk,j)=hi12_12(iwk,j)+
     *   dwf_12(mciesp,iwk)*gi12pnt_12(j)   
         hi12_12(j,iwk)=hi12_12(j,iwk)+
     *   dwf_12(mciesp,iwk)*gi12pnt_12(j)  
       enddo                                                           
            enddo                                                      
c                                                                      
c            ddwf2_23= ddw2_23(mciesp)/wsum_p12-                       
c     *  we11_23(mciesp)*sddw2_23/(wsum_p12*wsum_p12)                  
            do ik=1,mcnicb                                             
              iwk=mciicb(ik)                                           
              detqk_23=dqs_23(iwk,mciesp)                              
              do is=ik,mcnicb                                          
                iws=mciicb(is)                                         
                detqs_23=dqs_23(iws,mciesp)                            
c        d2wf_23=(ddw1_23(mciesp)*detqk_23*detqs_23*wsum_p12           
c     *  -dw11_23(mciesp)*detqk_23*sdw_23(is)                          
c     *  -we11_23(mciesp)*sddw1_23(is,ik)                              
c     *  -dw11_23(mciesp)*detqs_23*sdw_23(ik)                          
c     *  +2.d0*we11_23(mciesp)*sdw_23(ik)*                             
c     *  sdw_23(is)/wsum_p12)/(wsum_p12**2)                            
c        if(iws .eq. iwk)d2wf_23=d2wf_23+ddwf2_23                      
        hi12_23(iws,iwk)=hi12_23(iws,iwk)+
     *  d2wf_23(iws,iwk,mciesp)*e12p_23(mciesp)  
        hi12_23(iwk,iws)=hi12_23(iws,iwk)                         
              enddo                                                    
c                                                                      
c   3. calculate cross terms                                           
c                                                                      
       do j=1,mcnics                                                   
c         hi12_23(iwk,j)=hi12_23(iwk,j)+dwf_23(ik)*gi12pnt_23(j)       
c         hi12_23(j,iwk)=hi12_23(j,iwk)+dwf_23(ik)*gi12pnt_23(j)       
         hi12_23(iwk,j)=hi12_23(iwk,j)+
     *   dwf_23(mciesp,iwk)*gi12pnt_23(j) 
         hi12_23(j,iwk)=hi12_23(j,iwk)+
     *   dwf_23(mciesp,iwk)*gi12pnt_23(j)
       enddo                                                          
            enddo                                                     
c                                                                     
c            ddwf2_13 = ddw2_13(mciesp)/wsum_p12-                     
c     *  we11_13(mciesp)*sddw2_13/(wsum_p12*wsum_p12)                 
            do ik=1,mcnicb                                            
              iwk=mciicb(ik)                                          
              detqk_13=dqs_13(iwk,mciesp)                             
              do is=ik,mcnicb                                         
                iws=mciicb(is)                                        
                detqs_13=dqs_13(iws,mciesp)                           
c        d2wf_13=(ddw1_13(mciesp)*detqk_13*detqs_13*wsum_p12          
c     *  -dw11_13(mciesp)*detqk_13*sdw_13(is)                         
c     *  -we11_13(mciesp)*sddw1_13(is,ik)                             
c     *  -dw11_13(mciesp)*detqs_13*sdw_13(ik)                         
c     *  +2.d0*we11_13(mciesp)*sdw_13(ik)*                            
c     *  sdw_13(is)/wsum_p12)/(wsum_p12**2)                           
c        if(iws .eq. iwk)d2wf_13=d2wf_13+ddwf2_13                     
        hi12_13(iws,iwk)=hi12_13(iws,iwk)+
     *  d2wf_13(iws,iwk,mciesp)*e12p_13(mciesp)  
        hi12_13(iwk,iws)=hi12_13(iws,iwk)                            
              enddo                                                   
c                                                                     
c   3. calculate cross terms                                          
c                                                                     
       do j=1,mcnics                                                  
c         hi12_13(iwk,j)=hi12_13(iwk,j)+dwf_13(ik)*gi12pnt_13(j)        
c         hi12_13(j,iwk)=hi12_13(j,iwk)+dwf_13(ik)*gi12pnt_13(j)        
         hi12_13(iwk,j)=hi12_13(iwk,j)+
     *   dwf_13(mciesp,iwk)*gi12pnt_13(j)   
         hi12_13(j,iwk)=hi12_13(j,iwk)+
     *   dwf_13(mciesp,iwk)*gi12pnt_13(j)  
       enddo                                                            
            enddo                                                       
c                                                                       
c            ddwf2_123 = ddw2_123(mciesp)/wsum_p12-                     
c     *  we11_123(mciesp)*sddw2_123/(wsum_p12*wsum_p12)                 
            do ik=1,mcnicb                                              
              iwk=mciicb(ik)                                            
              detqk_123=dqs_123(iwk,mciesp)                             
              do is=ik,mcnicb                                           
                iws=mciicb(is)                                          
                detqs_123=dqs_123(iws,mciesp)                           
c        d2wf_123=(ddw1_123(mciesp)*detqk_123*detqs_123*wsum_p12        
c     *  -dw11_123(mciesp)*detqk_123*sdw_123(is)                        
c     *  -we11_123(mciesp)*sddw1_123(is,ik)                             
c     *  -dw11_123(mciesp)*detqs_123*sdw_123(ik)                        
c     *  +2.d0*we11_123(mciesp)*sdw_123(ik)*                            
c     *  sdw_123(is)/wsum_p12)/(wsum_p12**2)                            
c        if(iws .eq. iwk)d2wf_123=d2wf_123+ddwf2_123                    
        hi12_123(iws,iwk)=hi12_123(iws,iwk)+                            
     *  d2wf_123(iws,iwk,mciesp)*e12p_123(mciesp)                    
        hi12_123(iwk,iws)=hi12_123(iws,iwk)                             
              enddo                                                   
c                                                                     
c   3. calculate cross terms                                          
c                                                                     
       do j=1,mcnics                                                  
c         hi12_123(iwk,j)=hi12_123(iwk,j)+                            
c     *  dwf_123(ik)*gi12pnt_123(j)                                   
c         hi12_123(j,iwk)=hi12_123(j,iwk)+                            
c     *   dwf_123(ik)*gi12pnt_123(j)                                  
         hi12_123(iwk,j)=hi12_123(iwk,j)+                             
     *  dwf_123(mciesp,ik)*gi12pnt_123(j)    
         hi12_123(j,iwk)=hi12_123(j,iwk)+                             
     *   dwf_123(mciesp,ik)*gi12pnt_123(j)      
       enddo                                                          
            enddo                                                     
c                                                                     
c            ddwf2_132 = ddw2_132(mciesp)/wsum_p12-                   
c     *  we11_132(mciesp)*sddw2_132/(wsum_p12*wsum_p12)               
            do ik=1,mcnicb                                            
              iwk=mciicb(ik)                                          
              detqk_132=dqs_132(iwk,mciesp)                           
              do is=ik,mcnicb                                         
                iws=mciicb(is)                                        
                detqs_132=dqs_132(iws,mciesp)                         
c        d2wf_132=(ddw1_132(mciesp)*detqk_132*detqs_132*wsum_p12      
c     *  -dw11_132(mciesp)*detqk_132*sdw_132(is)                       
c     *  -we11_132(mciesp)*sddw1_132(is,ik)                            
c     *  -dw11_132(mciesp)*detqs_132*sdw_132(ik)                       
c     *  +2.d0*we11_132(mciesp)*sdw_132(ik)*                           
c     *  sdw_132(is)/wsum_p12)/(wsum_p12**2)                           
c        if(iws .eq. iwk)d2wf_132=d2wf_132+ddwf2_132                   
        hi12_132(iws,iwk)=hi12_132(iws,iwk)+                           
     *  d2wf_132(iws,iwk,mciesp)*e12p_132(mciesp)                    
        hi12_132(iwk,iws)=hi12_132(iws,iwk)                            
              enddo                                                    
c                                                                      
c   3. calculate cross terms                                           
c                                                                      
       do j=1,mcnics                                                   
c         hi12_132(iwk,j)=hi12_132(iwk,j)+                             
c     *   dwf_132(ik)*gi12pnt_132(j)                                   
c         hi12_132(j,iwk)=hi12_132(j,iwk)+                             
c     *   dwf_132(ik)*gi12pnt_132(j)                                   
         hi12_132(iwk,j)=hi12_132(iwk,j)+                              
     *   dwf_132(mciesp,ik)*gi12pnt_132(j)                            
         hi12_132(j,iwk)=hi12_132(j,iwk)+                              
     *   dwf_132(mciesp,ik)*gi12pnt_132(j)                           
       enddo                                                           
            enddo                                                      
c 
c              do ik=1,mcnicb                                          
c              iwk=mciicb(ik)                                          
c              do is=ik,mcnicb                                         
c                iws=mciicb(is)                                        
c        hi12(iws,iwk)=hi12_E(iws,iwk)+hi12_12(iws,iwk)+               
c     *  hi12_23(iws,iwk)+hi12_13(iws,iwk)+                            
c     *  hi12_123(iws,iwk)+hi12_132(iws,iwk)                           
c        hi12(iwk,iws)=hi12(iws,iwk)                                   
c              enddo                                                   
c              do j=1,mcnics                                           
c              hi12(iwk,j)=hi12_E(iwk,j)+hi12_12(iwk,j)+               
c     *  hi12_23(iwk,j)+hi12_13(iwk,j)+                                
c     *  hi12_123(iwk,j)+hi12_132(iwk,j)                               
c              enddo                                                     
c              enddo     
c sum_i=1^{6}             
              do i=1,mcnics
        hi12(i,i)=hi12_E(i,i)+hi12_12(i,i)+              
     *  hi12_23(i,i)+hi12_13(i,i)+                           
     *  hi12_123(i,i)+hi12_132(i,i)                          
              enddo   
c sum_i=1^{6} off-diagonal
              do i=1,mcnics
              do j=1,mcnics                                          
              hi12(i,j)=hi12_E(i,j)+hi12_12(i,j)+              
     *  hi12_23(i,j)+hi12_13(i,j)+                               
     *  hi12_123(i,j)+hi12_132(i,j)                              
              enddo
              enddo
          endif                                                         
c        endif  
c     end of loop over number of shepard points                         
c                                                                       
 1000 continue 
c          
      return                                                            
      end                                                               
c***********************************************************************
c     mcv12iold
c***********************************************************************
c
      subroutine mcv12iold(e12,gi12,hi12,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).
c
      implicit double precision (a-h, o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      dimension dqs(mcmics,mcmesp+2),dqd(mcmicd,mcmesp+2)
      dimension w(mcmesp*6+12)
c      dimension dw(mcmesp+2)
c      dimension ddw1(mcmesp+2),ddw2(mcmesp+2)
c      dimension sdw(mcmics),sddw1(mcmics,mcmics)
      dimension d2wf(mcmicd,mcmicd,mcmesp*6+12)
c       dimension d2wf(mcmicd,mcmicd,mcmesp+2)
c
c      dimension e12pnt(mcmesp+2),e12pf(mcmesp+2),e12p(mcmesp+2)
      dimension e12pnt(mcmesp),e12pf(mcmesp),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)
      dimension hh12(mcmics,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,mcmics
        hh12(i,j)=0.d0
      enddo
      enddo
      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
c      do i=1,mcmesp+2
       do i=1,mcmesp
c       do i=1,mcmesp
c        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
        uterm(i) = 0.0d0
      enddo
         do i=1,mcmesp*6+12
c          do i=1,mcmesp+12
           w(i)   =  0.d0
          do j=1,mcmics
            dwf(i,j)  = 0.d0
          enddo
      enddo
      do i=1,mcmics
        gi12(i)  = 0.d0
        gi12a(i)  = 0.d0
        gi12b(i)  = 0.d0
        wrk1(i)  = 0.d0
      enddo
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
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     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
      if (mcsins.ne.0) goto 2000                                         0527MH10
c
      do 1000 mciesp=1,mcnesp
        if (w(mciesp).gt.0.d0) then
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
c     Added to avoid negative values for V12**2 term, 4/14/99 by Y. Kim
c
c          delta = 0.00000001d0
c           udelta = 0.0000000256d0
c           unn = 2
          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------------------ 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
          do k=1,mcnics
            if (e12p(mciesp).gt.0.0) then
c              gi12pnt(k)=0.5d0*(aevbm(mciesp)*(bevbm(k,mciesp)+0.5d0*
c     *          (wrk(k)+wrk1(k)))*fixf+delta*fixf*(bevbm(k,mciesp)+
c     *                 0.5d0*(wrk(k)+wrk1(k)))/be12)/e12pnt(mciesp)
                gi12pnt(k)=0.5d0*aevbm(mciesp)*(bevbm(k,mciesp)          1206OT08
     *          +0.5d0*(wrk(k)+wrk1(k)))*fixf/e12pnt(mciesp)*            1206OT08
     *          (1.d0+fixf*unn*(uterm(mciesp))**unn)                       1206OT08
            else
              gi12pnt(k)=0.0d0
            endif
          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)     
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 hessian -----
c
c     first check if it is necessary (itypec = 1)
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                hi12(is,ik)=hi12(is,ik)+(-gi12pnt(is)*gi12pnt(ik)+            
c     *           0.5d0*(aevbm(mciesp)*fixf*0.5d0*(cevbm(is,ik,mciesp)+
c     *                  cevbm(ik,is,mciesp))+delta*delta*fixf*
c     *                (bevbm(is,mciesp)+0.5d0*(wrk(is)+wrk1(is)))*
c     *                 (bevbm(ik,mciesp)+0.5d0*(wrk(ik)+wrk1(ik)))/    
c     *            (aevbm(mciesp)*be12**3)+0.5d0*(cevbm(is,ik,mciesp)+
c     *                   cevbm(ik,is,mciesp))*delta*fixf/be12))
c     *                    /e12pnt(mciesp)*w(mciesp)                           0505OT07
                hi12(is,ik)=hi12(is,ik)+(-gi12pnt(is)*gi12pnt(ik)+             0612OT08
     *          aevbm(mciesp)*aevbm(mciesp)*unn*unn*fixf*fixf*                   0612OT08
     *          (bevbm(is,mciesp)+0.5d0*(wrk(is)+wrk1(is)))*                   0612OT08
     *          (bevbm(ik,mciesp)+                                             0612OT08
     *          0.5d0*(wrk(ik)+wrk1(ik)))/e12p(mciesp)*                        0612OT08
     *      uterm(mciesp)**unn*(unn*fixf*uterm(mciesp)**unn-unn+1.d0)+         0612OT08
     *          0.5d0*aevbm(mciesp)*0.5d0*(cevbm(is,ik,mciesp)+                0612OT08
     *          cevbm(ik,is,mciesp))*fixf*(unn*fixf*uterm(mciesp)**unn+          0612OT08
     *          1.d0))/e12pnt(mciesp)*w(mciesp)                                0612OT08
                hi12(ik,is)=hi12(is,ik)                                        0612OT08
              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
      return
c
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
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
c     Added to avoid negative values for V12**2 term, 4/14/99 by Y. Kim
c
c          delta = 0.00000001d0
c           udelta = 0.0000000256d0
c           unn = 2
          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          write (6,*) "WW", w(mciesp),mciesp
c
c------------------end of e12------------------------------------
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
          do k=1,mcnics
            if (e12p(mciesp).gt.0.0d0) then
                gi12pnt(k)=0.5d0*aevbm(mciesp)*(bevbm(k,mciesp)
     *          +0.5d0*(wrk(k)+wrk1(k)))*ddqs2(k,mciesp)
     *          *fixf/e12pnt(mciesp)*
     *          (1.d0+fixf*unn*(uterm(mciesp))**unn)
            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)^2
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 hessian -----
c
c     first check if it is necessary (itypec = 1)
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
              hi12(ik,ik)=hi12(ik,ik)+w(mciesp)
     &                   *0.5d0*aevbm(mciesp)*(bevbm(ik,mciesp)
     &                   +0.5d0*(wrk(ik)+wrk1(ik)))*d2dqs2(ik,mciesp)
     *          *fixf/e12pnt(mciesp)*
     *          (1.d0+fixf*unn*(uterm(mciesp))**unn)
              do is=ik,mcnics
                hi12(is,ik)=hi12(is,ik)+(-gi12pnt(is)*gi12pnt(ik)+             0612OT08
     *          aevbm(mciesp)*aevbm(mciesp)*unn*unn*fixf*fixf*                   0612OT08
     *          (bevbm(is,mciesp)+0.5d0*(wrk(is)+wrk1(is)))*                   0612OT08
     *          ddqs2(is,mciesp)*ddqs2(ik,mciesp)*      
     *          (bevbm(ik,mciesp)+                                             0612OT08
     *          0.5d0*(wrk(ik)+wrk1(ik)))/e12p(mciesp)*                        0612OT08
     *      uterm(mciesp)**unn*(unn*fixf*uterm(mciesp)**unn-unn+1.d0)+         0612OT08
     *          0.5d0*aevbm(mciesp)*0.5d0*(cevbm(is,ik,mciesp)+                0612OT08
     *          cevbm(ik,is,mciesp))*ddqs2(is,mciesp)*ddqs2(ik,mciesp)*
     *          fixf*(unn*fixf*uterm(mciesp)**unn+
     *          1.d0))/e12pnt(mciesp)*w(mciesp)                                0612OT08
                hi12(ik,is)=hi12(is,ik)                                        0612OT08
              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
      return
c<<<<                                                                    0527MH10
      end
c***********************************************************************
c     mcv12i1st
c***********************************************************************
c
      subroutine mcv12i1st(e12,gi12,hi12,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
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.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 e12pnt(mcmesp),e12pf(mcmesp),e12p(mcmesp)
      dimension gi12pnt(mcmics),gi12(mcmics),hi12(mcmics,mcmics)
c      dimension wrk(mcmics),wrk1(mcmics),gi12a(mcmics),gi12b(mcmics)
      dimension gi12a(mcmics),gi12b(mcmics)
      dimension dwf(mcmesp*6+12,mcmics)
c      dimension dwf(mcmesp+2,mcmics)
      dimension hh12(mcmics,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,mcmics
      do j=1,mcmics
        hh12(i,j)=0.d0
      enddo
      enddo
      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
c      do i=1,mcmesp+2
       do i=1,mcmesp
        e12pnt(i) = 0.0d0
        e12pf(i) = 0.0d0
        e12p(i) = 0.0d0
      enddo
         do i=1,mcmesp*6+12
c          do i=1,mcmesp+2
           w(i)   =  0.d0
          do j=1,mcmics
            dwf(i,j)  = 0.d0
          enddo
      enddo
      do i=1,mcmics
        gi12(i)  = 0.d0
        gi12a(i)  = 0.d0
        gi12b(i)  = 0.d0
c        wrk1(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
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
      if (mcsins.ne.0) goto 2000                                         0527MH10
c
      do 1000 mciesp=1,mcnesp
        if (w(mciesp).gt.0.d0) then
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
c            wrk(i) =0.d0
            btrm=btrm+bevbm(i,mciesp)*dqs(i,mciesp)
c            do j=1,mcnics
c              wrk(i)=wrk(i)+dqs(j,mciesp)*cevbm(i,j,mciesp)
c            enddo
c            ctrm=ctrm+dqs(i,mciesp)*wrk(i)
          enddo
c
          be12 = 1.d0+btrm
          e12p(mciesp) = aevbm(mciesp)*be12
c |V12|^2=          
          e12 = e12+w(mciesp)*e12p(mciesp)                              0108OT09
c          write (*,*) "e12=", e12,w(mciesp),mciesp,aevbm(mciesp),be12
c
c------------------end of e12------------------------------------
c
c------------------ begin calculating the first derivatives -----
c
c     first check if it is necessary (itypec >= 1)
c
          if (itypec .eq. 1) goto 1000
c          do k=1,mcnics
c            wrk1s = 0.d0
c              do k1 = 1,mcnics
c                wrk1s = wrk1s+cevbm(k1,k,mciesp)*dqs(k1,mciesp)
c              enddo
c            wrk1(k) = wrk1s
c          enddo
          do k=1,mcnics
                gi12pnt(k)=aevbm(mciesp)*bevbm(k,mciesp)                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------------------ begin calculating the hessian -----
c
c     first check if it is necessary (itypec = 1)
c
          if (itypec .eq. 2) goto 1000
c
c   1. calculate dd(e12(i))/(dqs(k)dqs(s))*w(i))                              0505OT07
c
c            do ik=1,mcnics
c              do is=ik,mcnics
c                  hi12(is,ik)=hi12(is,ik)+aevbm(mciesp)*                      0108OT09
c     *            0.5d0*(cevbm(is,ik,mciesp)+                                 0108OT09
c     *            cevbm(ik,is,mciesp))*w(mciesp)                              0108OT09
c                  hi12(ik,is)=hi12(is,ik)                           
c              enddo
c            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
      return
c
c>>>>                                                                    0527MH10
 2000 continue
c
c     ----- use sin(pn*d(dihedral)) for dihedral angles -----
c
      do 1001 mciesp=1,mcnesp
        if (w(mciesp).gt.0.d0) then
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
            btrm=btrm+bevbm(i,mciesp)*dqs2(i,mciesp)
          enddo
c
          be12 = 1.d0+btrm
          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 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
            gi12pnt(k)=aevbm(mciesp)*bevbm(k,mciesp)*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------------------ begin calculating the hessian -----
c
c     first check if it is necessary (itypec = 1)
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)*d2dqs2(ik,mciesp)
c
            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
      return
c<<<<                                                                    0527MH10
      end
c***********************************************************************
c     mcv12i
c***********************************************************************
c
      subroutine mcv12i(e12,gi12,hi12,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
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.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 e12pnt(mcmesp),e12pf(mcmesp),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)
      dimension hh12(mcmics,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,mcmics
      do j=1,mcmics
        hh12(i,j)=0.d0
      enddo
      enddo
      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
c      do i=1,mcmesp+2
       do i=1,mcmesp
        e12pnt(i) = 0.0d0
        e12pf(i) = 0.0d0
        e12p(i) = 0.0d0
      enddo
         do i=1,mcmesp*6+12
c          do i=1,mcmesp+2
           w(i)   =  0.d0
          do j=1,mcmics
            dwf(i,j)  = 0.d0
          enddo
      enddo
      do i=1,mcmics
        gi12(i)  = 0.d0
        gi12a(i)  = 0.d0
        gi12b(i)  = 0.d0
        wrk1(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
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
      if (mcsins.ne.0) goto 2000                                         0527MH10
c
      do 1000 mciesp=1,mcnesp
        if (w(mciesp).gt.0.d0) then
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
          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 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
          do k=1,mcnics
                gi12pnt(k)=aevbm(mciesp)*(bevbm(k,mciesp)+              0108OT09
     *           0.5d0*(wrk(k)+wrk1(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------------------ begin calculating the hessian -----
c
c     first check if it is necessary (itypec = 1)
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
      return
c
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
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
          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 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
          do k=1,mcnics
                gi12pnt(k)=aevbm(mciesp)*(bevbm(k,mciesp)+              0108OT09
     *           0.5d0*(wrk(k)+wrk1(k)))*ddqs2(k,mciesp)
          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------------------ begin calculating the hessian -----
c
c     first check if it is necessary (itypec = 1)
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)))*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
c
            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
      return
c<<<<                                                                    0527MH10
      end
c***********************************************************************
c     mcv12is
c***********************************************************************
c
      subroutine mcv12is(e12,gi12,hi12,itypec)
c
c     This subroutine is a modified version of mcv12i subroutine.
c     It returns symmetrized V12, its gradient and Hessian.
c     The formalism is described in 'Tishchenko & Truhlar, JCTC 2007, 3, 938-948'.    
c     The current version only supports systems with n = 3 identical nuclei.
c     (O.T. November 2006; modifications June 2007)
c
      implicit double precision (a-h, o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      dimension dqs(mcmics,mcmesp+2)
      dimension dqs_12(mcmics,mcmesp+2)
      dimension dqs_23(mcmics,mcmesp+2)
      dimension dqs_13(mcmics,mcmesp+2)
      dimension dqs_123(mcmics,mcmesp+2)
      dimension dqs_132(mcmics,mcmesp+2)
      dimension w_p12(mcmesp*6+12)
      dimension w(mcmesp+2)
      dimension we11(mcmesp)                                          
      dimension we11_12(mcmesp)                                       
      dimension we11_23(mcmesp)                                       
      dimension we11_13(mcmesp)                                       
      dimension we11_123(mcmesp)                                      
      dimension we11_132(mcmesp)                                      
c      dimension F(mcmesp)
c      dimension F_12(mcmesp)
c      dimension F_23(mcmesp)
c      dimension F_13(mcmesp)
c      dimension F_123(mcmesp)
c      dimension F_132(mcmesp)
c      dimension cat(mcmesp)
c      dimension cat_12(mcmesp)
c      dimension cat_13(mcmesp)
c      dimension cat_23(mcmesp)
c      dimension cat_123(mcmesp)
c      dimension cat_132(mcmesp)
       dimension uterm(mcmesp)
       dimension uterm_12(mcmesp)
       dimension uterm_13(mcmesp)
       dimension uterm_23(mcmesp)
       dimension uterm_123(mcmesp)
       dimension uterm_132(mcmesp)
c
c      dimension dw11(mcmesp)
c      dimension dw11_12(mcmesp)                                      
c      dimension dw11_23(mcmesp)                                      
c      dimension dw11_13(mcmesp)                                      
c      dimension dw11_123(mcmesp)                                     
c      dimension dw11_132(mcmesp)                                     
c
      dimension indexw(mcmesp,6)
c      dimension w_12(mcmesp+2),dw_12(mcmesp+2)                       
c      dimension ddw1(mcmesp+2),ddw2(mcmesp+2)                        
c      dimension ddw1_E(mcmesp),ddw2_E(mcmesp)                        
c      dimension ddw1_12(mcmesp),ddw2_12(mcmesp)                      
c      dimension ddw1_23(mcmesp),ddw2_23(mcmesp)                      
c      dimension ddw1_13(mcmesp),ddw2_13(mcmesp)                      
c      dimension ddw1_123(mcmesp),ddw2_123(mcmesp)                    
c      dimension ddw1_132(mcmesp),ddw2_132(mcmesp)                    
c      dimension ddw1_p12(mcmesp*2+4),ddw2_p12(mcmesp*2+4)            
c      dimension sdw(mcmics),sddw1(mcmics,mcmics)
c      dimension sdw_p12(mcmics),sddw1_p12(mcmics,mcmics)            
c      dimension sdw_12(mcmics),sddw1_12(mcmics,mcmics)              
c      dimension sdw_23(mcmics),sddw1_23(mcmics,mcmics)              
c      dimension sdw_13(mcmics),sddw1_13(mcmics,mcmics)              
c      dimension sdw_123(mcmics),sddw1_123(mcmics,mcmics)            
c      dimension sdw_132(mcmics),sddw1_132(mcmics,mcmics)            
c
      dimension e12pnt(mcmesp),e12pf(mcmesp),e12p(mcmesp)
      dimension e12pnt_12(mcmesp),e12pf_12(mcmesp),             
     *          e12p_12(mcmesp)                                   
      dimension e12pnt_23(mcmesp),e12pf_23(mcmesp),             
     *          e12p_23(mcmesp)                                   
      dimension e12pnt_13(mcmesp),e12pf_13(mcmesp),             
     *          e12p_13(mcmesp)                                   
      dimension e12pnt_123(mcmesp),e12pf_123(mcmesp),           
     *          e12p_123(mcmesp)                                  
      dimension e12pnt_132(mcmesp),e12pf_132(mcmesp),           
     *          e12p_132(mcmesp)                                  
      dimension gi12pnt(mcmics),gi12(mcmics),hi12(mcmics,mcmics)
      dimension gi12_E(mcmics),hi12_E(mcmics,mcmics)               
      dimension gi12pnt_12(mcmics),gi12_12(mcmics),                
     * hi12_12(mcmics,mcmics)                                      
      dimension gi12pnt_23(mcmics),gi12_23(mcmics),                
     * hi12_23(mcmics,mcmics)                                      
      dimension gi12pnt_13(mcmics),gi12_13(mcmics),                
     * hi12_13(mcmics,mcmics)                                      
      dimension gi12pnt_123(mcmics),gi12_123(mcmics),              
     * hi12_123(mcmics,mcmics)                                     
      dimension gi12pnt_132(mcmics),gi12_132(mcmics),              
     * hi12_132(mcmics,mcmics)                                     
      dimension wrk(mcmics),wrk1(mcmics)
      dimension wrk_12(mcmics),wrk1_12(mcmics)                          
      dimension wrk_23(mcmics),wrk1_23(mcmics)                          
      dimension wrk_13(mcmics),wrk1_13(mcmics)                          
      dimension wrk_123(mcmics),wrk1_123(mcmics)                        
      dimension wrk_132(mcmics),wrk1_132(mcmics)                        
c      dimension dwf(mcmics)
      dimension  dwf(mcmesp*6+12,mcmicd)
      dimension  dwf_12(mcmesp+2,mcmicd)
      dimension  dwf_E(mcmesp+2,mcmicd)
      dimension  dwf_23(mcmesp+2,mcmicd)
      dimension  dwf_13(mcmesp+2,mcmicd)
      dimension  dwf_123(mcmesp+2,mcmicd)
      dimension  dwf_132(mcmesp+2,mcmicd)
      dimension  d2wf(mcmicd,mcmicd,mcmesp*6+12)
      dimension  d2wf_E(mcmicd,mcmicd,mcmesp+2)
      dimension  d2wf_12(mcmicd,mcmicd,mcmesp+2)
      dimension  d2wf_23(mcmicd,mcmicd,mcmesp+2)
      dimension  d2wf_13(mcmicd,mcmicd,mcmesp+2)
      dimension  d2wf_123(mcmicd,mcmicd,mcmesp+2)
      dimension  d2wf_132(mcmicd,mcmicd,mcmesp+2)
c
      zero = 0.d0
c 
c     zero out Shepard variables
c
c      do i=1,mcmics
c        do j=1,mcmesp+2
       do j=1,mcmesp+2
         do i=1,mcmics
          dqs(i,j) =  0.d0
          dqs_12(i,j) =  0.d0
          dqs_23(i,j) =  0.d0
          dqs_13(i,j) =  0.d0
          dqs_123(i,j) =  0.d0
          dqs_132(i,j) =  0.d0
        enddo
      enddo
      do i=1,mcmesp+2
      do j=1,mcmicd
      dwf_E(i,j)=0.d0
      dwf_12(i,j)=0.d0
      dwf_23(i,j)=0.d0
      dwf_13(i,j)=0.d0
      dwf_123(i,j)=0.d0
      dwf_132(i,j)=0.d0
      enddo
      enddo
      do k=1,mcmesp+2
      do i=1,mcmicd
      do j=1,mcmicd
      d2wf_E(i,j,k)=0.d0
      d2wf_12(i,j,k)=0.d0
      d2wf_23(i,j,k)=0.d0
      d2wf_13(i,j,k)=0.d0
      d2wf_123(i,j,k)=0.d0
      d2wf_132(i,j,k)=0.d0
      enddo
      enddo
      enddo
c      do i=1,mcmesp+2
      do i=1,mcmesp
        w(i)   =  0.d0
        e12pnt(i) = 0.0d0
        e12pf(i) = 0.0d0
        e12p(i) = 0.0d0
        e12pnt_12(i) = 0.0d0                                            
        e12pf_12(i) = 0.0d0                                             
        e12p_12(i) = 0.0d0                                              
        w_p12(i)   =  0.d0                                              
        e12pnt_23(i) = 0.0d0                                            
        e12pf_23(i) = 0.0d0                                             
        e12p_23(i) = 0.0d0                                              
        e12pnt_13(i) = 0.0d0                                            
        e12pf_13(i) = 0.0d0                                             
        e12p_13(i) = 0.0d0                                              
        e12pnt_123(i) = 0.0d0                                           
        e12pf_123(i) = 0.0d0                                            
        e12p_123(i) = 0.0d0                                             
        e12pnt_132(i) = 0.0d0                                           
        e12pf_132(i) = 0.0d0                                            
        e12p_132(i) = 0.0d0                                             
          do j=1,mcmics
            dwf(i,j)  = 0.d0
          enddo
      enddo       
       do i=1,mcmesp                                                    
        we11(i)=0.0d0                                                   
        we11_12(i)=0.0d0                                                
        we11_23(i)=0.0d0                                                
        we11_13(i)=0.0d0                                                
        we11_123(i)=0.0d0                                               
        we11_132(i)=0.0d0                                               
c        F(i)=0.0d0
c        F_12(i)=0.0d0
c        F_23(i)=0.0d0
c        F_13(i)=0.0d0
c        F_123(i)=0.0d0
c        F_132(i)=0.0d0
c        cat(i)=0.0d0
c        cat_12(i)=0.0d0
c        cat_23(i)=0.0d0
c        cat_13(i)=0.0d0
c        cat_123(i)=0.0d0
c        cat_132(i)=0.0d0
        enddo     
c        do i=1,mcmesp*6
c        Fw(i)=0.d0
c        enddo
      do i = 1, mcmics
         do j = 1, mcmics
            hi12(i,j) = zero
            hi12_E(i,j) = zero
            hi12_12(i,j) = zero                                         
            hi12_23(i,j) = zero                                         
            hi12_13(i,j) = zero                                         
            hi12_123(i,j) = zero                                        
            hi12_132(i,j) = zero                                        
         end do
         gi12(i)=zero
         gi12_E(i)=zero                                                 
         gi12_12(i)=zero                                                
         gi12_23(i)=zero                                                
         gi12_13(i)=zero                                                
         gi12_123(i)=zero                                               
         gi12_132(i)=zero                                               
      end do
       do i=1,6
       do j=1,mcmesp
        indexw(i,j)=0
       enddo
       enddo
      do i=1,mcmics                                                     
        gi12pnt(i)  = 0.d0                                              
        gi12pnt_12(i)  = 0.d0                                           
        gi12pnt_23(i)  = 0.d0                                           
        gi12pnt_13(i)  = 0.d0                                           
        gi12pnt_123(i)  = 0.d0                                          
        gi12pnt_132(i)  = 0.d0                                          
      enddo
c
       e12 = zero
       e12_12 = zero                                                    
       e12_23 = zero                                                    
       e12_13 = zero                                                    
       e12_123 = zero                                                   
       e12_132 = zero                                                   
             e12a= zero                                                 
             e12b= zero                                                 
             e12c= zero                                                 
             e12d= zero                                                 
             e12e= zero                                                 
             e12f= zero                                                 
c
c     calculate the displacement in internal coordinates used for
c     generalized distances
c
c       qs(1)=qs(1)-0.0001
c       qd(1)=qd(1)-0.0001
c
       do j=1,mcnesp+2
         do i=1,mcnics
          dqs(i,j)=qs(i)-qs0(i,j)
          dqs_12(i,j)=qs(i)-qs0_12(i,j)                                 
          dqs_23(i,j)=qs(i)-qs0_23(i,j)                                 
          dqs_13(i,j)=qs(i)-qs0_13(i,j)                                 
          dqs_123(i,j)=qs(i)-qs0_123(i,j)                               
          dqs_132(i,j)=qs(i)-qs0_132(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
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas                 
               if (dqs_12(i,j).lt.-fpi) then                            
                   dqs_12(i,j) = dqs_12(i,j)+2.0d0*fpi                  
               elseif (dqs_12(i,j).gt.fpi) then                         
                   dqs_12(i,j) = dqs_12(i,j)-2.0d0*fpi                  
               endif                                                    
            enddo                                                       
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas                 
               if (dqs_23(i,j).lt.-fpi) then                            
                   dqs_23(i,j) = dqs_23(i,j)+2.0d0*fpi                  
               elseif (dqs_23(i,j).gt.fpi) then                         
                   dqs_23(i,j) = dqs_23(i,j)-2.0d0*fpi                  
               endif                                                    
            enddo                                                       
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas                 
               if (dqs_13(i,j).lt.-fpi) then                            
                   dqs_13(i,j) = dqs_13(i,j)+2.0d0*fpi                  
               elseif (dqs_13(i,j).gt.fpi) then                         
                   dqs_13(i,j) = dqs_13(i,j)-2.0d0*fpi                  
               endif                                                    
            enddo                                                       
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas                 
               if (dqs_123(i,j).lt.-fpi) then                           
                   dqs_123(i,j) = dqs_123(i,j)+2.0d0*fpi                
               elseif (dqs_123(i,j).gt.fpi) then                        
                   dqs_123(i,j) = dqs_123(i,j)-2.0d0*fpi                
               endif                                                    
            enddo                                                       
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas                 
               if (dqs_132(i,j).lt.-fpi) then                           
                   dqs_132(i,j) = dqs_132(i,j)+2.0d0*fpi                
               elseif (dqs_132(i,j).gt.fpi) then                        
                   dqs_132(i,j) = dqs_132(i,j)-2.0d0*fpi                
               endif                                                    
            enddo                                                       
         endif
      enddo
c
c get weights
c
       call mcswtsnum(w_p12,dwf,d2wf,itypec)
c
          j = 0
c
c  loop over all (m!N) Shepard points to select weights+derivatives for the ES points
c  and leave out the data for MM structures 1 and 2.                      
           k=2                                                          
c                                                                       
           do i=0,5                                                     
           do j=1,mcnesp                                                
           indexw(j,i+1)=mcnesp*i+k*i+j                                 
           enddo                                                        
           enddo                                                        
c                                                                       
          do j = 1, mcnesp                                              
          we11(j)=w_p12(indexw(j,1))                                    
          do i=1,mcnicd
          dwf_E(j,i)=dwf(indexw(j,1),i)
          do k=1,mcnicd
          d2wf_E(i,k,j)=d2wf(i,k,indexw(j,1))
          enddo
          enddo
c          dw11(j)=dw_p12(indexw(j,1))                                  
c          ddw1_E(j)=ddw1_p12(indexw(j,1))                              
c          ddw2_E(j)=ddw2_p12(indexw(j,1))                              
          enddo                                                         
          do j = 1, mcnesp                                              
          we11_12(j)=w_p12(indexw(j,2))                                 
          do i=1,mcnicd
          dwf_12(j,i)=dwf(indexw(j,2),i)
          do k=1,mcnicd
          d2wf_12(i,k,j)=d2wf(i,k,indexw(j,2))
          enddo
          enddo
c          dw11_12(j)=dw_p12(indexw(j,2))                              
c          ddw1_12(j)=ddw1_p12(indexw(j,2))                            
c          ddw2_12(j)=ddw2_p12(indexw(j,2))                            
          enddo                                                        
          do j = 1, mcnesp                                             
          we11_23(j)=w_p12(indexw(j,3))                                
          do i=1,mcnicd
          dwf_23(j,i)=dwf(indexw(j,3),i)
          do k=1,mcnicd
          d2wf_23(i,k,j)=d2wf(i,k,indexw(j,3))
          enddo
          enddo
c          dw11_23(j)=dw_p12(indexw(j,3))                              
c          ddw1_23(j)=ddw1_p12(indexw(j,3))                             
c          ddw2_23(j)=ddw2_p12(indexw(j,3))                            
          enddo                                                        
          do j = 1, mcnesp                                             
          we11_13(j)=w_p12(indexw(j,4))                                
          do i=1,mcnicd
          dwf_13(j,i)=dwf(indexw(j,4),i)
          do k=1,mcnicd
          d2wf_13(i,k,j)=d2wf(i,k,indexw(j,4))
          enddo
          enddo
c          dw11_13(j)=dw_p12(indexw(j,4))                             
c          ddw1_13(j)=ddw1_p12(indexw(j,4))                           
c          ddw2_13(j)=ddw2_p12(indexw(j,4))                           
          enddo                                                       
          do j = 1, mcnesp                                            
          we11_123(j)=w_p12(indexw(j,5))                              
          do i=1,mcnicd
          dwf_123(j,i)=dwf(indexw(j,5),i)
          do k=1,mcnicd
          d2wf_123(i,k,j)=d2wf(i,k,indexw(j,5))
          enddo
          enddo
c          dw11_123(j)=dw_p12(indexw(j,5))                             
c          ddw1_123(j)=ddw1_p12(indexw(j,5))                           
c          ddw2_123(j)=ddw2_p12(indexw(j,5))                           
          enddo                                                        
          do j = 1, mcnesp                                             
          we11_132(j)=w_p12(indexw(j,6))                               
          do i=1,mcnicd
          dwf_132(j,i)=dwf(indexw(j,6),i)
          do k=1,mcnicd
          d2wf_132(i,k,j)=d2wf(i,k,indexw(j,6))
          enddo
          enddo
c          dw11_132(j)=dw_p12(indexw(j,6))                            
c          ddw1_132(j)=ddw1_p12(indexw(j,6))                          
c          ddw2_132(j)=ddw2_p12(indexw(j,6))                          
          enddo                                                       
          do j = 1, mcnesp                                            
          enddo  
c          
       do 1000 mciesp=1,mcnesp                                                           
c
          btrm=0.d0
          ctrm=0.d0
          qtrm=0.d0
          btrm_12=0.d0                                                  
          btrm_23=0.d0                                                  
          btrm_13=0.d0                                                  
          btrm_123=0.d0                                                 
          btrm_132=0.d0                                                 
          ctrm_12=0.d0                                                  
          ctrm_23=0.d0                                                  
          ctrm_13=0.d0                                                  
          ctrm_123=0.d0                                                 
          ctrm_132=0.d0                                                 
          qtrm_12=0.d0                                                  
          be12=0.d0                                                     
          be12_12=0.d0                                                  
          be12_23=0.d0                                                  
          be12_13=0.d0                                                  
          be12_123=0.d0                                                 
          be12_132=0.d0                                                 
c
          do i=1,mcnics
            wrk(i) =0.d0
            wrk_12(i) =0.d0                                             
            wrk_23(i) =0.d0                                             
            wrk_13(i) =0.d0                                             
            wrk_123(i) =0.d0                                            
            wrk_132(i) =0.d0                                            
            btrm=btrm+bevbm(i,mciesp)*dqs(i,mciesp)                     
            btrm_12=btrm_12+bevbm_12(i,mciesp)*dqs_12(i,mciesp)          
            btrm_23=btrm_23+bevbm_23(i,mciesp)*dqs_23(i,mciesp)         
            btrm_13=btrm_13+bevbm_13(i,mciesp)*dqs_13(i,mciesp)         
            btrm_123=btrm_123+bevbm_123(i,mciesp)*dqs_123(i,mciesp)     
            btrm_132=btrm_132+bevbm_132(i,mciesp)*dqs_132(i,mciesp)     
            do j=1,mcnics
              wrk(i)=wrk(i)+dqs(j,mciesp)*cevbm(i,j,mciesp)
          wrk_12(i)=wrk_12(i)+dqs_12(j,mciesp)*cevbm_12(i,j,mciesp)     
          wrk_23(i)=wrk_23(i)+dqs_23(j,mciesp)*cevbm_23(i,j,mciesp)     
          wrk_13(i)=wrk_13(i)+dqs_13(j,mciesp)*cevbm_13(i,j,mciesp)     
          wrk_123(i)=wrk_123(i)+dqs_123(j,mciesp)*cevbm_123(i,j,mciesp) 
          wrk_132(i)=wrk_132(i)+dqs_132(j,mciesp)*cevbm_132(i,j,mciesp) 
            enddo
            ctrm=ctrm+dqs(i,mciesp)*wrk(i)
            ctrm_12=ctrm_12+dqs_12(i,mciesp)*wrk_12(i)                  
            ctrm_23=ctrm_23+dqs_23(i,mciesp)*wrk_23(i)                  
            ctrm_13=ctrm_13+dqs_13(i,mciesp)*wrk_13(i)                  
            ctrm_123=ctrm_123+dqs_123(i,mciesp)*wrk_123(i)              
            ctrm_132=ctrm_132+dqs_132(i,mciesp)*wrk_132(i)              
          enddo
c
c     Added to avoid negative values for V12**2 term, 4/14/99 by Y. Kim
c
c           delta = 0.00016d0
c           udelta = 0.0000000256d0
c           unn = 2.d0
          be12 = 1.d0+btrm+0.5d0*ctrm
          be12_12 = 1.d0+btrm_12+0.5d0*ctrm_12                            
          be12_23 = 1.d0+btrm_23+0.5d0*ctrm_23                             
          be12_13 = 1.d0+btrm_13+0.5d0*ctrm_13                             
          be12_123 = 1.d0+btrm_123+0.5d0*ctrm_123                         
          be12_132 = 1.d0+btrm_132+0.5d0*ctrm_132                         
          e12p(mciesp) = aevbm(mciesp)*be12
          e12p_12(mciesp) = aevbm(mciesp)*be12_12                       
          e12p_23(mciesp) = aevbm(mciesp)*be12_23                       
          e12p_13(mciesp) = aevbm(mciesp)*be12_13                       
          e12p_123(mciesp) = aevbm(mciesp)*be12_123                     
          e12p_132(mciesp) = aevbm(mciesp)*be12_132                     
c
ccc          if (e12p(mciesp).gt.0.0d0) then
cc            fixf = dexp(-delta/e12p(mciesp))
cc              fixf = 1.d0/(1.d0+(delta/e12p(mciesp))**unn)
ccc              uterm(mciesp)=udelta/e12p(mciesp)                          1206OT08
ccc              fixf = 1.d0/(1.d0+(uterm(mciesp))**unn)                    1206OT08
ccc          else
ccc            fixf = 0.0d0
ccc          endif
ccc          if (e12p_12(mciesp).gt.0.0d0) then                            
cc            fixf_12 = dexp(-delta/e12p_12(mciesp))                      
cc              fixf_12 = 1.d0/(1.d0+(delta/e12p_12(mciesp))**unn)
ccc              uterm_12(mciesp)=udelta/e12p_12(mciesp)                          1206OT08
ccc              fixf_12 = 1.d0/(1.d0+(uterm_12(mciesp))**unn)                    1206OT08
ccc          else                                                          
ccc            fixf_12 = 0.0d0                                             
ccc          endif                                                         
ccc          if (e12p_23(mciesp).gt.0.0d0) then                            
cc            fixf_23 = dexp(-delta/e12p_23(mciesp))                      
cc             fixf_23 = 1.d0/(1.d0+(delta/e12p_23(mciesp))**unn)
ccc              uterm_23(mciesp)=udelta/e12p_23(mciesp)                          1206OT08
ccc              fixf_23 = 1.d0/(1.d0+(uterm_23(mciesp))**unn)                    1206OT08
ccc          else                                                          
ccc            fixf_23 = 0.0d0                                             
ccc          endif                                                         
ccc          if (e12p_13(mciesp).gt.0.0d0) then                            
cc            fixf_13 = dexp(-delta/e12p_13(mciesp))                      
cc            fixf_13 = 1.d0/(1.d0+(delta/e12p_13(mciesp))**unn)
ccc              uterm_13(mciesp)=udelta/e12p_13(mciesp)                          1206OT08
ccc              fixf_13 = 1.d0/(1.d0+(uterm_13(mciesp))**unn)                    1206OT08
ccc          else                                                          
ccc            fixf_13 = 0.0d0                                             
ccc          endif                                                         
ccc          if (e12p_123(mciesp).gt.0.0d0) then                           
cc            fixf_123 = dexp(-delta/e12p_123(mciesp))                    
cc            fixf_123 = 1.d0/(1.d0+(delta/e12p_123(mciesp))**unn)
ccc              uterm_123(mciesp)=udelta/e12p_123(mciesp)                          1206OT08
ccc              fixf_123 = 1.d0/(1.d0+(uterm_123(mciesp))**unn)                    1206OT08
ccc          else                                                          
ccc            fixf_123 = 0.0d0                                            
ccc          endif                                                         
ccc          if (e12p_132(mciesp).gt.0.0d0) then                           
cc            fixf_132 = dexp(-delta/e12p_132(mciesp))                    
cc           fixf_132 = 1.d0/(1.d0+(delta/e12p_132(mciesp))**unn)
ccc              uterm_132(mciesp)=udelta/e12p_132(mciesp)                          1206OT08
ccc              fixf_132 = 1.d0/(1.d0+(uterm_132(mciesp))**unn)                    1206OT08
ccc          else                                                          
ccc            fixf_132 = 0.0d0                                            
ccc          endif                                                         
c          e12pf(mciesp) = abs(e12p(mciesp))
c          e12pf_12(mciesp) = abs(e12p_12(mciesp))
c          e12pf_23(mciesp) = abs(e12p_23(mciesp))
c          e12pf_13(mciesp) = abs(e12p_13(mciesp))
c          e12pf_123(mciesp) = abs(e12p_123(mciesp))
c          e12pf_132(mciesp) = abs(e12p_132(mciesp))
c
c          e12pnt(mciesp) = dsqrt(e12pf(mciesp))                         
c          e12pnt_12(mciesp) = dsqrt(e12pf_12(mciesp))                   
c          e12pnt_23(mciesp) = dsqrt(e12pf_23(mciesp))                   
c          e12pnt_13(mciesp) = dsqrt(e12pf_13(mciesp))                   
c          e12pnt_123(mciesp) = dsqrt(e12pf_123(mciesp))                 
c          e12pnt_132(mciesp) = dsqrt(e12pf_132(mciesp))                 
c
c          write (6,*) "WW", we11(mciesp),we11_12(mciesp),
c     *    we11_23(mciesp),we11_13(mciesp),we11_123(mciesp),
c     *    we11_132(mciesp),mciesp
c
        e12a = e12a+we11(mciesp)*e12p(mciesp)        
        e12b = e12b+we11_12(mciesp)*e12p_12(mciesp)    
        e12c = e12c+we11_23(mciesp)*e12p_23(mciesp)     
        e12d = e12d+we11_13(mciesp)*e12p_13(mciesp)     
        e12e = e12e+we11_123(mciesp)*e12p_123(mciesp)     
        e12f = e12f+we11_132(mciesp)*e12p_132(mciesp)     
        e12 = e12a + e12b + e12c + e12d + e12e +e12f
c        wsum=wsum+we11(mciesp)+we11_12(mciesp)+we11_23(mciesp)+
c     *  we11_13(mciesp)+we11_123(mciesp)+we11_132(mciesp)
c        write (6,*) "wsum=", wsum,e12,e12a,e12b,e12c,e12d,e12e,e12f
c
c------------------end of e12------------------------------------
c
c------------------ begin calculating the first derivatives -----
c
c     first check if it is necessary (itypec >= 1)
c
c          itypec=2
          if (itypec .eq. 1) goto 1000
          do k=1,mcnics
            wrk1s = 0.d0
            wrk1s_12 = 0.d0                                             
            wrk1s_23 = 0.d0                                             
            wrk1s_13 = 0.d0                                             
            wrk1s_123 = 0.d0                                            
            wrk1s_132 = 0.d0                                            
              do k1 = 1,mcnics                                          
                wrk1s = wrk1s+cevbm(k1,k,mciesp)*dqs(k1,mciesp)
                wrk1s_12 = wrk1s_12+                                    
     *    cevbm_12(k1,k,mciesp)*dqs_12(k1,mciesp)                       
                wrk1s_23 = wrk1s_23+                                    
     *    cevbm_23(k1,k,mciesp)*dqs_23(k1,mciesp)                       
                wrk1s_13 = wrk1s_13+                                    
     *    cevbm_13(k1,k,mciesp)*dqs_13(k1,mciesp)                       
                wrk1s_123 = wrk1s_123+                                  
     *    cevbm_123(k1,k,mciesp)*dqs_123(k1,mciesp)                     
                wrk1s_132 = wrk1s_132+                                  
     *    cevbm_132(k1,k,mciesp)*dqs_132(k1,mciesp)                     
              enddo                                                     
            wrk1(k) = wrk1s                                             
            wrk1_12(k) = wrk1s_12                                       
            wrk1_23(k) = wrk1s_23                                       
            wrk1_13(k) = wrk1s_13                                       
            wrk1_123(k) = wrk1s_123                                     
            wrk1_132(k) = wrk1s_132                                     
          enddo                                                         
          do k=1,mcnics                                                 
cccc            if (e12p(mciesp).gt.0.0) then                               
cc              gi12pnt(k)=0.5d0*(aevbm(mciesp)*(bevbm(k,mciesp)+0.5d0*   
cc     *          (wrk(k)+wrk1(k)))*fixf+delta*fixf*(bevbm(k,mciesp)+     
cc     *                 0.5d0*(wrk(k)+wrk1(k)))/be12)/e12pnt(mciesp)     
ccc                gi12pnt(k)=0.5d0*aevbm(mciesp)*((bevbm(k,mciesp)
ccc     *          +0.5d0*
ccc     *          (wrk(k)+wrk1(k)))*fixf+delta*unn*
ccc     *          (bevbm(k,mciesp)+
ccc     *          0.5d0*(wrk(k)+wrk1(k)))/e12p(mciesp)*
ccc     *          (delta/e12p(mciesp))**(unn-1)*(1+
ccc     *          (delta/e12p(mciesp))**unn)**(-2.d0))/e12pnt(mciesp)
cccc                gi12pnt(k)=0.5d0*aevbm(mciesp)*(bevbm(k,mciesp)
cccc     *          +0.5d0*(wrk(k)+wrk1(k)))*fixf/e12pnt(mciesp)*
cccc     *          (1.d0+fixf*unn*(delta/e12p(mciesp))**unn)
                gi12pnt(k)=aevbm(mciesp)*(bevbm(k,mciesp)+
     *           0.5d0*(wrk(k)+wrk1(k)))
c
cccc            else                                                        
cccc              gi12pnt(k)=0.0d0                                          
cccc            endif
c                                                                       
cccc            if (e12p_12(mciesp).gt.0.0) then                            
cc              gi12pnt_12(k)=0.5d0*(aevbm(mciesp)*(bevbm_12(k,mciesp)    
cc     *        +0.5d0*                                                   
cc     *        (wrk_12(k)+wrk1_12(k)))*fixf_12+delta*fixf_12*            
cc     *        (bevbm_12(k,mciesp)+                                      
cc     *       0.5d0*(wrk_12(k)+wrk1_12(k)))/be12_12)/e12pnt_12(mciesp)   
ccc                gi12pnt_12(k)=0.5d0*aevbm(mciesp)*((bevbm_12(k,mciesp)
ccc     *          +0.5d0*
ccc     *          (wrk_12(k)+wrk1_12(k)))*fixf_12+delta*unn*
ccc     *          (bevbm_12(k,mciesp)+
ccc     *          0.5d0*(wrk_12(k)+wrk1_12(k)))/e12p_12(mciesp)*
ccc     *          (delta/e12p_12(mciesp))**(unn-1)*(1+
ccc     *          (delta/e12p_12(mciesp))**unn)**(-2.d0))/e12pnt_12(mciesp)
cccc                gi12pnt_12(k)=0.5d0*aevbm(mciesp)*(bevbm_12(k,mciesp)
cccc     *       +0.5d0*(wrk_12(k)+wrk1_12(k)))*fixf_12/e12pnt_12(mciesp)*
cccc     *          (1.d0+fixf_12*unn*(delta/e12p_12(mciesp))**unn)
                gi12pnt_12(k)=aevbm(mciesp)*(bevbm_12(k,mciesp)+
     *           0.5d0*(wrk_12(k)+wrk1_12(k)))
cccc            else                                                        
cccc              gi12pnt_12(k)=0.0d0                                       
cccc            endif                                                       
c                                                                       
cccc            if (e12p_23(mciesp).gt.0.0) then                            
cc              gi12pnt_23(k)=0.5d0*(aevbm(mciesp)*(bevbm_23(k,mciesp)    
cc     *        +0.5d0*                                                   
cc     *        (wrk_23(k)+wrk1_23(k)))*fixf_23+delta*fixf_23*            
cc     *        (bevbm_23(k,mciesp)+                                      
cc     *       0.5d0*(wrk_23(k)+wrk1_23(k)))/be12_23)/e12pnt_23(mciesp)   
ccc                gi12pnt_23(k)=0.5d0*aevbm(mciesp)*((bevbm_23(k,mciesp)
ccc     *          +0.5d0*
ccc     *          (wrk_23(k)+wrk1_23(k)))*fixf_23+delta*unn*
ccc     *          (bevbm_23(k,mciesp)+
ccc     *          0.5d0*(wrk_23(k)+wrk1_23(k)))/e12p_23(mciesp)*
ccc     *          (delta/e12p_23(mciesp))**(unn-1)*(1+
ccc     *          (delta/e12p_23(mciesp))**unn)**(-2.d0))/e12pnt_23(mciesp)
cccc                gi12pnt_23(k)=0.5d0*aevbm(mciesp)*(bevbm_23(k,mciesp)
cccc     *       +0.5d0*(wrk_23(k)+wrk1_23(k)))*fixf_23/e12pnt_23(mciesp)*
cccc     *          (1.d0+fixf_23*unn*(delta/e12p_23(mciesp))**unn)
                gi12pnt_23(k)=aevbm(mciesp)*(bevbm_23(k,mciesp)+
     *           0.5d0*(wrk_23(k)+wrk1_23(k)))
cccc            else                                                        
cccc              gi12pnt_23(k)=0.0d0                                       
cccc            endif                                                       
c                                                                       
cccc            if (e12p_13(mciesp).gt.0.0) then                            
cc              gi12pnt_13(k)=0.5d0*(aevbm(mciesp)*(bevbm_13(k,mciesp)    
cc     *        +0.5d0*                                                   
cc     *        (wrk_13(k)+wrk1_13(k)))*fixf_13+delta*fixf_13*            
cc     *        (bevbm_13(k,mciesp)+                                      
cc     *       0.5d0*(wrk_13(k)+wrk1_13(k)))/be12_13)/e12pnt_13(mciesp)   
ccc                gi12pnt_13(k)=0.5d0*aevbm(mciesp)*((bevbm_13(k,mciesp)
ccc     *          +0.5d0*
ccc     *          (wrk_13(k)+wrk1_13(k)))*fixf_13+delta*unn*
ccc     *          (bevbm_13(k,mciesp)+
ccc     *          0.5d0*(wrk_13(k)+wrk1_13(k)))/e12p_13(mciesp)*
ccc     *          (delta/e12p_13(mciesp))**(unn-1)*(1+
ccc     *          (delta/e12p_13(mciesp))**unn)**(-2.d0))/e12pnt_13(mciesp)
cccc                gi12pnt_13(k)=0.5d0*aevbm(mciesp)*(bevbm_13(k,mciesp)
cccc     *       +0.5d0*(wrk_13(k)+wrk1_13(k)))*fixf_13/e12pnt_13(mciesp)*
cccc     *          (1.d0+fixf_13*unn*(delta/e12p_13(mciesp))**unn)
                gi12pnt_13(k)=aevbm(mciesp)*(bevbm_13(k,mciesp)+
     *           0.5d0*(wrk_13(k)+wrk1_13(k)))
cccc            else                                                        
cccc              gi12pnt_13(k)=0.0d0                                       
cccc            endif                                                       
c                                                                       
cccc            if (e12p_123(mciesp).gt.0.0) then                           
cc              gi12pnt_123(k)=0.5d0*(aevbm(mciesp)*(bevbm_123(k,mciesp)  
cc     *        +0.5d0*                                                   
cc     *        (wrk_123(k)+wrk1_123(k)))*fixf_123+delta*fixf_123*        
cc     *        (bevbm_123(k,mciesp)+                                     
cc     *        0.5d0*(wrk_123(k)+                                        
cc     *        wrk1_123(k)))/be12_123)/e12pnt_123(mciesp)                
ccc                gi12pnt_123(k)=0.5d0*aevbm(mciesp)*((bevbm_123(k,mciesp)
ccc     *          +0.5d0*
ccc     *          (wrk_123(k)+wrk1_123(k)))*fixf_123+delta*unn*
ccc     *          (bevbm_123(k,mciesp)+
ccc     *          0.5d0*(wrk_123(k)+wrk1_123(k)))/e12p_123(mciesp)*
ccc     *          (delta/e12p_123(mciesp))**(unn-1)*(1+
ccc     *          (delta/e12p_123(mciesp))**unn)**(-2.d0))/
ccc     *          e12pnt_123(mciesp)
cccc                gi12pnt_123(k)=
cccc     *          0.5d0*aevbm(mciesp)*(bevbm_123(k,mciesp)
cccc     *          +0.5d0*(wrk_123(k)+
cccc     *          wrk1_123(k)))*fixf_123/e12pnt_123(mciesp)*
cccc     *          (1.d0+fixf_123*unn*(delta/e12p_123(mciesp))**unn)
                gi12pnt_123(k)=aevbm(mciesp)*(bevbm_123(k,mciesp)+
     *           0.5d0*(wrk_123(k)+wrk1_123(k)))
cccc            else                                                        
cccc              gi12pnt_123(k)=0.0d0                                      
cccc            endif                                                       
c                                                                       
cccc            if (e12p_132(mciesp).gt.0.0) then                           
cc              gi12pnt_132(k)=0.5d0*(aevbm(mciesp)*(bevbm_132(k,mciesp)  
cc     *        +0.5d0*                                                   
cc     *        (wrk_132(k)+wrk1_132(k)))*fixf_132+delta*fixf_132*        
cc     *        (bevbm_132(k,mciesp)+                                     
cc     *        0.5d0*(wrk_132(k)+                                        
cc     *        wrk1_132(k)))/be12_132)/e12pnt_132(mciesp)                
ccc                gi12pnt_132(k)=0.5d0*aevbm(mciesp)*((bevbm_132(k,mciesp)
ccc     *          +0.5d0*
ccc     *          (wrk_132(k)+wrk1_132(k)))*fixf_132+delta*unn*
ccc     *          (bevbm_132(k,mciesp)+
ccc     *          0.5d0*(wrk_132(k)+wrk1_132(k)))/e12p_132(mciesp)*
ccc     *          (delta/e12p_132(mciesp))**(unn-1)*(1+
ccc     *          (delta/e12p_132(mciesp))**unn)**(-2.d0))/
ccc     *          e12pnt_132(mciesp)
cccc                gi12pnt_132(k)=
cccc     *          0.5d0*aevbm(mciesp)*(bevbm_132(k,mciesp)
cccc     *          +0.5d0*(wrk_132(k)+
cccc     *          wrk1_132(k)))*fixf_132/e12pnt_132(mciesp)*
cccc     *          (1.d0+fixf_132*unn*(delta/e12p_132(mciesp))**unn)
                gi12pnt_132(k)=aevbm(mciesp)*(bevbm_132(k,mciesp)+
     *           0.5d0*(wrk_132(k)+wrk1_132(k)))
cccc            else                                                        
cccc              gi12pnt_132(k)=0.0d0                                      
cccc            endif                                                       
c                                                                       
          enddo
c                                                                       
c     weight the gradient                                               
c                                                                       
          do k=1,mcnics                                                 
            gi12_E(k) = gi12_E(k) + gi12pnt(k)*we11(mciesp)
            gi12_12(k) = gi12_12(k) +                                  
     *     gi12pnt_12(k)*we11_12(mciesp)
           gi12_23(k) = gi12_23(k) +                                   
     *     gi12pnt_23(k)*we11_23(mciesp)
           gi12_13(k) = gi12_13(k) +                                   
     *     gi12pnt_13(k)*we11_13(mciesp)
           gi12_123(k) = gi12_123(k) +                                 
     *     gi12pnt_123(k)*we11_123(mciesp)
           gi12_132(k) = gi12_132(k) +                                 
     *     gi12pnt_132(k)*we11_132(mciesp)
c           write (*,*) "gi12",gi12_E(k),gi12_12(k),gi12_23(k),
c     *     gi12_13(k),gi12_123(k),gi12_132(k),k
c           write (*,*) "gi12",gi12_13(k),gi12pnt_13(k),we11_13(mciesp)
c            write (*,*) "gi12pnt(k)",gi12pnt(k),gi12pnt_12(k),
c     *    gi12pnt_23(k),gi12pnt_13(k),gi12pnt_123(k),gi12pnt_132(k),k
          enddo
c            do k=1,mcnics
c         gi12(k)=gi12_E(k)+gi12_12(k)+gi12_23(k)+
c     &   gi12_13(k)+gi12_123(k)+gi12_132(k)  
c            enddo
c 
c     if shepard interpolation is used, calculate dwf(k)=dW(i)/dqs(k)
c
        if (mcimre.eq.2) then
        do k=1,mcnicb
              kw=mciicb(k)
cccc        gi12_E(kw)=gi12_E(kw)+e12pnt(mciesp)*dwf_E(mciesp,kw)
        gi12_E(kw)=gi12_E(kw)+e12p(mciesp)*dwf_E(mciesp,kw)
c
cccc        gi12_12(kw)=gi12_12(kw)+e12pnt_12(mciesp)*dwf_12(mciesp,kw)            
        gi12_12(kw)=gi12_12(kw)+e12p_12(mciesp)*dwf_12(mciesp,kw)
c              
cccc        gi12_23(kw)=gi12_23(kw)+e12pnt_23(mciesp)*dwf_23(mciesp,kw)           
        gi12_23(kw)=gi12_23(kw)+e12p_23(mciesp)*dwf_23(mciesp,kw)
c               
cccc        gi12_13(kw)=gi12_13(kw)+e12pnt_13(mciesp)*dwf_13(mciesp,kw)          
        gi12_13(kw)=gi12_13(kw)+e12p_13(mciesp)*dwf_13(mciesp,kw)
c               
cccc        gi12_123(kw)=gi12_123(kw)+
cccc     &   e12pnt_123(mciesp)*dwf_123(mciesp,kw)   
        gi12_123(kw)=gi12_123(kw)+
     &   e12p_123(mciesp)*dwf_123(mciesp,kw)
c               
cccc        gi12_132(kw)=gi12_132(kw)+
cccc     &   e12pnt_132(mciesp)*dwf_132(mciesp,kw)
        gi12_132(kw)=gi12_132(kw)+
     &   e12p_132(mciesp)*dwf_132(mciesp,kw)
c              
        enddo
        do k=1,mcnics
         gi12(k)=gi12_E(k)+gi12_12(k)+gi12_23(k)+
     &   gi12_13(k)+gi12_123(k)+gi12_132(k)  
        enddo
        endif
c
c----------------- end of first derivative calculations ------
c
c------------------ begin calculating the hessian -----
c
c     first check if it is necessary (itypec = 1)
c
          if (itypec .eq. 2) goto 1000
c
c   1. calculate dd(e12(i))/(dqs(k)dqs(s))*w(i)
c
cc          if (e12p(mciesp).gt.0.0) then
            do ik=1,mcnics
              do is=ik,mcnics
c                hi12_E(is,ik)=hi12_E(is,ik)+(-gi12pnt(is)*gi12pnt(ik)+
c     *           0.5d0*(aevbm(mciesp)*fixf*0.5d0*(cevbm(is,ik,mciesp)+
c     *                  cevbm(ik,is,mciesp))+delta*delta*fixf*
c     *                (bevbm(is,mciesp)+0.5d0*(wrk(is)+wrk1(is)))*
c     *                 (bevbm(ik,mciesp)+0.5d0*(wrk(ik)+wrk1(ik)))/    
c     *            (aevbm(mciesp)*be12**3)+0.5d0*(cevbm(is,ik,mciesp)+
c     *                   cevbm(ik,is,mciesp))*delta*fixf/be12))
c     *                    /e12pnt(mciesp)*we11(mciesp)
c
cc               hi12_E(is,ik)=hi12_E(is,ik)+(-gi12pnt(is)*gi12pnt(ik)+         0612OT08
cc     *          aevbm(mciesp)*aevbm(mciesp)*unn*unn*fixf*fixf*                   0612OT08
cc     *          (bevbm(is,mciesp)+0.5d0*(wrk(is)+wrk1(is)))*                   0612OT08
cc     *          (bevbm(ik,mciesp)+                                             0612OT08
cc     *          0.5d0*(wrk(ik)+wrk1(ik)))/e12p(mciesp)*                        0612OT08
cc     *      uterm(mciesp)**unn*(unn*fixf*uterm(mciesp)**unn-unn+1.d0)+         0612OT08
cc     *          0.5d0*aevbm(mciesp)*0.5d0*(cevbm(is,ik,mciesp)+                0612OT08
cc     *        cevbm(ik,is,mciesp))*fixf*(unn*fixf*uterm(mciesp)**unn+          0612OT08
cc     *          1.d0))/e12pnt(mciesp)*we11(mciesp)                             0612OT08
cc                hi12_E(ik,is)=hi12_E(is,ik)              
                  hi12_E(is,ik)=hi12_E(is,ik)+aevbm(mciesp)*
     *            0.5d0*(cevbm(is,ik,mciesp)+
     *            cevbm(ik,is,mciesp))*we11(mciesp)
                  hi12_E(ik,is)=hi12_E(is,ik)
              enddo
            enddo
cc          endif
c
cc          if (e12p_12(mciesp).gt.0.0) then                              
            do ik=1,mcnics                                              
              do is=ik,mcnics                                           
c         hi12_12(is,ik)=hi12_12(is,ik)+
c     *   (-gi12pnt_12(is)*gi12pnt_12(ik)+
c     *   0.5d0*(aevbm(mciesp)*fixf_12*0.5d0*(cevbm_12(is,ik,mciesp)+    
c     *   cevbm_12(ik,is,mciesp))+delta*delta*fixf_12*                   
c     *   (bevbm_12(is,mciesp)+0.5d0*(wrk_12(is)+wrk1_12(is)))*          
c     *   (bevbm_12(ik,mciesp)+0.5d0*(wrk_12(ik)+wrk1_12(ik)))/          
c     *   (aevbm(mciesp)*be12_12**3)+0.5d0*(cevbm_12(is,ik,mciesp)+      
c     *   cevbm_12(ik,is,mciesp))*delta*fixf_12/be12_12))                
c     *   /e12pnt_12(mciesp)*we11_12(mciesp)
cc          hi12_12(is,ik)=hi12_12(is,ik)+
cc     *    (-gi12pnt_12(is)*gi12pnt_12(ik)+                                        0612OT08
cc     *    aevbm(mciesp)*aevbm(mciesp)*unn*unn*fixf_12*fixf_12*                      0612OT08
cc     *    (bevbm_12(is,mciesp)+0.5d0*(wrk_12(is)+wrk1_12(is)))*                   0612OT08
cc     *    (bevbm_12(ik,mciesp)+                                                   0612OT08
cc     *    0.5d0*(wrk_12(ik)+wrk1_12(ik)))/e12p_12(mciesp)*                        0612OT08
cc     *    uterm_12(mciesp)**unn*(unn*fixf_12*uterm_12(mciesp)**unn-unn                0612OT08
cc     *    +1.d0)+                                                                 0612OT08
cc     *    0.5d0*aevbm(mciesp)*0.5d0*(cevbm_12(is,ik,mciesp)+                      0612OT08
cc     *    cevbm_12(ik,is,mciesp))*                                                0612OT08
cc     *    fixf_12*(unn*fixf_12*uterm_12(mciesp)**unn+                               0612OT08
cc     *    1.d0))/e12pnt_12(mciesp)*we11_12(mciesp)                                0612OT08
cc          hi12_12(ik,is)=hi12_12(is,ik)                                           
                  hi12_12(is,ik)=hi12_12(is,ik)+aevbm(mciesp)*
     *            0.5d0*(cevbm_12(is,ik,mciesp)+
     *            cevbm_12(ik,is,mciesp))*we11_12(mciesp)
                  hi12_12(ik,is)=hi12_12(is,ik)
              enddo                                                     
            enddo                                                       
cc          endif                                                         
c                                                                       
cc          if (e12p_23(mciesp).gt.0.0) then                              
            do ik=1,mcnics                                              
              do is=ik,mcnics                                           
c          hi12_23(is,ik)=hi12_23(is,ik)+
c     *    (-gi12pnt_23(is)*gi12pnt_23(ik)+
c     *    0.5d0*(aevbm(mciesp)*fixf_23*0.5d0*(cevbm_23(is,ik,mciesp)+   
c     *    cevbm_23(ik,is,mciesp))+delta*delta*fixf_23*                  
c     *    (bevbm_23(is,mciesp)+0.5d0*(wrk_23(is)+wrk1_23(is)))*         
c     *    (bevbm_23(ik,mciesp)+0.5d0*(wrk_23(ik)+wrk1_23(ik)))/         
c     *    (aevbm(mciesp)*be12_23**3)+0.5d0*(cevbm_23(is,ik,mciesp)+     
c     *    cevbm_23(ik,is,mciesp))*delta*fixf_23/be12_23))               
c     *    /e12pnt_23(mciesp)*we11_23(mciesp)
cc          hi12_23(is,ik)=hi12_23(is,ik)+
cc     *    (-gi12pnt_23(is)*gi12pnt_23(ik)+                                        0612OT08
cc     *    aevbm(mciesp)*aevbm(mciesp)*unn*unn*fixf_23*fixf_23*                      0612OT08
cc     *    (bevbm_23(is,mciesp)+0.5d0*(wrk_23(is)+wrk1_23(is)))*                   0612OT08
cc     *    (bevbm_23(ik,mciesp)+                                                   0612OT08
cc     *    0.5d0*(wrk_23(ik)+wrk1_23(ik)))/e12p_23(mciesp)*                        0612OT08
cc     *    uterm_23(mciesp)**unn*(unn*fixf_23*uterm_23(mciesp)**unn-unn                0612OT08
cc     *    +1.d0)+                                                                 0612OT08
cc     *    0.5d0*aevbm(mciesp)*0.5d0*(cevbm_23(is,ik,mciesp)+                      0612OT08
cc     *    cevbm_23(ik,is,mciesp))*                                                0612OT08
cc    *    fixf_23*(unn*fixf_23*uterm_23(mciesp)**unn+                               0612OT08
cc     *    1.d0))/e12pnt_23(mciesp)*we11_23(mciesp)                                0612OT08
cc                hi12_23(ik,is)=hi12_23(is,ik)                                     
                  hi12_23(is,ik)=hi12_23(is,ik)+aevbm(mciesp)*
     *            0.5d0*(cevbm_23(is,ik,mciesp)+
     *            cevbm_23(ik,is,mciesp))*we11_23(mciesp)
                  hi12_23(ik,is)=hi12_23(is,ik)
              enddo                                                     
            enddo                                                       
cc          endif                                                         
c                                                                       
cc          if (e12p_13(mciesp).gt.0.0) then                              
            do ik=1,mcnics                                              
              do is=ik,mcnics                                           
c          hi12_13(is,ik)=hi12_13(is,ik)+
c     *    (-gi12pnt_13(is)*gi12pnt_13(ik)+
c     *    0.5d0*(aevbm(mciesp)*fixf_13*0.5d0*(cevbm_13(is,ik,mciesp)+   
c     *    cevbm_13(ik,is,mciesp))+delta*delta*fixf_13*                  
c     *    (bevbm_13(is,mciesp)+0.5d0*(wrk_13(is)+wrk1_13(is)))*         
c     *    (bevbm_13(ik,mciesp)+0.5d0*(wrk_13(ik)+wrk1_13(ik)))/         
c     *    (aevbm(mciesp)*be12_13**3)+0.5d0*(cevbm_13(is,ik,mciesp)+     
c     *    cevbm_13(ik,is,mciesp))*delta*fixf_13/be12_13))               
c     *    /e12pnt_13(mciesp)*we11_13(mciesp)
cc          hi12_13(is,ik)=hi12_13(is,ik)+
cc     *    (-gi12pnt_13(is)*gi12pnt_13(ik)+                                        0612OT08
cc     *    aevbm(mciesp)*aevbm(mciesp)*unn*unn*fixf_13*fixf_13*                      0612OT08
cc     *    (bevbm_13(is,mciesp)+0.5d0*(wrk_13(is)+wrk1_13(is)))*                   0612OT08
cc     *    (bevbm_13(ik,mciesp)+                                                   0612OT08
cc     *    0.5d0*(wrk_13(ik)+wrk1_13(ik)))/e12p_13(mciesp)*                        0612OT08
cc     *    uterm_13(mciesp)**unn*(unn*fixf_13*uterm_13(mciesp)**unn-unn                0612OT08
cc     *    +1.d0)+                                                                 0612OT08
cc     *    0.5d0*aevbm(mciesp)*0.5d0*(cevbm_13(is,ik,mciesp)+                      0612OT08
cc     *    cevbm_13(ik,is,mciesp))*                                                0612OT08
cc     *    fixf_13*(unn*fixf_13*uterm_13(mciesp)**unn+                               0612OT08
cc     *    1.d0))/e12pnt_13(mciesp)*we11_13(mciesp)                                0612OT08
cc                hi12_13(ik,is)=hi12_13(is,ik)                                     
                  hi12_13(is,ik)=hi12_13(is,ik)+aevbm(mciesp)*
     *            0.5d0*(cevbm_13(is,ik,mciesp)+
     *            cevbm_13(ik,is,mciesp))*we11_13(mciesp)
                  hi12_13(ik,is)=hi12_13(is,ik)
              enddo                                                     
            enddo                                                       
cc          endif                                                         
c                                                                       
cc          if (e12p_123(mciesp).gt.0.0) then                             
            do ik=1,mcnics                                              
              do is=ik,mcnics                                           
c        hi12_123(is,ik)=hi12_123(is,ik)+(-gi12pnt_123(is)*              
c     *  gi12pnt_123(ik)+                                                
c     *  0.5d0*(aevbm(mciesp)*fixf_123*0.5d0*(cevbm_123(is,ik,mciesp)+   
c     *  cevbm_123(ik,is,mciesp))+delta*delta*fixf_123*                  
c     *  (bevbm_123(is,mciesp)+0.5d0*(wrk_123(is)+wrk1_123(is)))*        
c     *  (bevbm_123(ik,mciesp)+0.5d0*(wrk_123(ik)+wrk1_123(ik)))/        
c     *  (aevbm(mciesp)*be12_123**3)+0.5d0*(cevbm_123(is,ik,mciesp)+     
c     *  cevbm_123(ik,is,mciesp))*delta*fixf_123/be12_123))              
c     *  /e12pnt_123(mciesp)*we11_123(mciesp)
cc          hi12_123(is,ik)=hi12_123(is,ik)+
cc     *    (-gi12pnt_123(is)*gi12pnt_123(ik)+                                       0612OT08
cc     *    aevbm(mciesp)*aevbm(mciesp)*unn*unn*fixf_123*fixf_123*                     0612OT08
cc     *    (bevbm_123(is,mciesp)+0.5d0*(wrk_123(is)+wrk1_123(is)))*                 0612OT08
cc     *    (bevbm_123(ik,mciesp)+                                                   0612OT08
cc     *    0.5d0*(wrk_123(ik)+wrk1_123(ik)))/e12p_123(mciesp)*                      0612OT08
cc     * uterm_123(mciesp)**unn*(unn*fixf_123*uterm_123(mciesp)**unn-unn              0612OT08
cc     *    +1.d0)+                                                                  0612OT08
cc     *    0.5d0*aevbm(mciesp)*0.5d0*(cevbm_123(is,ik,mciesp)+                      0612OT08
cc     *    cevbm_123(ik,is,mciesp))*                                                0612OT08
cc     *    fixf_123*(unn*fixf_123*uterm_123(mciesp)**unn+                             0612OT08
cc     *    1.d0))/e12pnt_123(mciesp)*we11_123(mciesp)                               0612OT08
cc               hi12_123(ik,is)=hi12_123(is,ik)                         
                  hi12_123(is,ik)=hi12_123(is,ik)+aevbm(mciesp)*
     *            0.5d0*(cevbm_123(is,ik,mciesp)+
     *            cevbm_123(ik,is,mciesp))*we11_123(mciesp)
                  hi12_123(ik,is)=hi12_123(is,ik)
              enddo                                                     
            enddo                                                       
cc          endif                                                         
c                                                                       
cc          if (e12p_132(mciesp).gt.0.0) then                             
            do ik=1,mcnics                                              
              do is=ik,mcnics                                           
c         hi12_132(is,ik)=hi12_132(is,ik)+(-gi12pnt_132(is)*             
c     *   gi12pnt_132(ik)+                                               
c     *   0.5d0*(aevbm(mciesp)*fixf_132*0.5d0*(cevbm_132(is,ik,mciesp)+  
c     *   cevbm_132(ik,is,mciesp))+delta*delta*fixf_132*                 
c     *   (bevbm_132(is,mciesp)+0.5d0*(wrk_132(is)+wrk1_132(is)))*       
c     *   (bevbm_132(ik,mciesp)+0.5d0*(wrk_132(ik)+wrk1_132(ik)))/       
c     *   (aevbm(mciesp)*be12_132**3)+0.5d0*(cevbm_132(is,ik,mciesp)+    
c     *   cevbm_132(ik,is,mciesp))*delta*fixf_132/be12_132))             
c     *   /e12pnt_132(mciesp)*we11_132(mciesp)
cc          hi12_132(is,ik)=hi12_132(is,ik)+
cc     *    (-gi12pnt_132(is)*gi12pnt_132(ik)+
cc     *    aevbm(mciesp)*aevbm(mciesp)*unn*unn*fixf_132*fixf_132*                      0612OT08
cc     *    (bevbm_132(is,mciesp)+0.5d0*(wrk_132(is)+wrk1_132(is)))*                  0612OT08
cc     *    (bevbm_132(ik,mciesp)+                                                    0612OT08
cc    *    0.5d0*(wrk_132(ik)+wrk1_132(ik)))/e12p_132(mciesp)*                       0612OT08
cc     * uterm_132(mciesp)**unn*(unn*fixf_132*uterm_132(mciesp)**unn-unn               0612OT08
cc     *    +1.d0)+                                                                   0612OT08
cc     *    0.5d0*aevbm(mciesp)*0.5d0*(cevbm_132(is,ik,mciesp)+                       0612OT08
cc     *    cevbm_132(ik,is,mciesp))*                                                 0612OT08
cc     *    fixf_132*(unn*fixf_132*uterm_132(mciesp)**unn+                              0612OT08
cc     *    1.d0))/e12pnt_132(mciesp)*we11_132(mciesp)                                0612OT08
cc                hi12_132(ik,is)=hi12_132(is,ik)                                    
                  hi12_132(is,ik)=hi12_132(is,ik)+aevbm(mciesp)*
     *            0.5d0*(cevbm_132(is,ik,mciesp)+
     *            cevbm_132(ik,is,mciesp))*we11_132(mciesp)
                  hi12_132(ik,is)=hi12_132(is,ik)
              enddo                                                     
            enddo                                                       
cc          endif                                                         
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                                         
c            ddwf2_E = ddw2_E(mciesp)/wsum_p12-                              
c     *   we11(mciesp)*sddw2/(wsum_p12*wsum_p12)                         
            do ik=1,mcnicb                                              
              iwk=mciicb(ik)                                            
c              detqk=dqs(iwk,mciesp)                                     
              do is=ik,mcnicb                                           
                iws=mciicb(is)                                          
c                detqs=dqs(iws,mciesp)                                   
c                d2wf_E=(ddw1_E(mciesp)*detqk*detqs*wsum_p12               
c     *              -dw11(mciesp)*detqk*sdw(is)                         
c     *              -we11(mciesp)*sddw1(is,ik)                          
c     *              -dw11(mciesp)*detqs*sdw(ik)                           
c     *              +2.d0*we11(mciesp)*sdw(ik)*
c     *               sdw(is)/wsum_p12)/(wsum_p12**2)  
c                if(iws .eq. iwk)d2wf_E=d2wf_E+ddwf2_E                         
                hi12_E(iws,iwk)=hi12_E(iws,iwk)+
     *          d2wf_E(iws,iwk,mciesp)*e12p(mciesp)         
                hi12_E(iwk,iws)=hi12_E(iws,iwk)                             
              enddo        
c                                                                       
c   3. calculate cross terms                                            
c                                                                       
              do j=1,mcnics                                             
c                hi12_E(iwk,j)=hi12_E(iwk,j)+dwf(ik)*gi12pnt(j)              
c                hi12_E(j,iwk)=hi12_E(j,iwk)+dwf(ik)*gi12pnt(j)              
                hi12_E(iwk,j)=hi12_E(iwk,j)+
     *          dwf_E(mciesp,iwk)*gi12pnt(j)
                hi12_E(j,iwk)=hi12_E(j,iwk)+
     *          dwf_E(mciesp,iwk)*gi12pnt(j)
              enddo                                                     
             enddo                                                      
c                                                                       
c            ddwf2_12 = ddw2_12(mciesp)/wsum_p12-                      
c     *  we11_12(mciesp)*sddw2_12/(wsum_p12*wsum_p12)                  
            do ik=1,mcnicb                                             
              iwk=mciicb(ik)                                           
              detqk_12=dqs_12(iwk,mciesp)                              
              do is=ik,mcnicb                                          
                iws=mciicb(is)                                         
                detqs_12=dqs_12(iws,mciesp)                            
c        d2wf_12=(ddw1_12(mciesp)*detqk_12*detqs_12*wsum_p12           
c     *  -dw11_12(mciesp)*detqk_12*sdw_12(is)                          
c     *  -we11_12(mciesp)*sddw1_12(is,ik)                              
c     *  -dw11_12(mciesp)*detqs_12*sdw_12(ik)                          
c     *  +2.d0*we11_12(mciesp)*sdw_12(ik)*                             
c     *  sdw_12(is)/wsum_p12)/(wsum_p12**2)                            
c        if(iws .eq. iwk)d2wf_12=d2wf_12+ddwf2_12                      
        hi12_12(iws,iwk)=hi12_12(iws,iwk)+
     *  d2wf_12(iws,iwk,mciesp)*e12p_12(mciesp)  
        hi12_12(iwk,iws)=hi12_12(iws,iwk)                              
              enddo                                                    
c                                                                      
c   3. calculate cross terms                                           
c                                                                      
       do j=1,mcnics                                                   
c         hi12_12(iwk,j)=hi12_12(iwk,j)+dwf_12(ik)*gi12pnt_12(j)       
c         hi12_12(j,iwk)=hi12_12(j,iwk)+dwf_12(ik)*gi12pnt_12(j)       
         hi12_12(iwk,j)=hi12_12(iwk,j)+
     *   dwf_12(mciesp,iwk)*gi12pnt_12(j)   
         hi12_12(j,iwk)=hi12_12(j,iwk)+
     *   dwf_12(mciesp,iwk)*gi12pnt_12(j)  
       enddo                                                           
            enddo                                                      
c                                                                      
c            ddwf2_23= ddw2_23(mciesp)/wsum_p12-                       
c     *  we11_23(mciesp)*sddw2_23/(wsum_p12*wsum_p12)                  
            do ik=1,mcnicb                                             
              iwk=mciicb(ik)                                           
              detqk_23=dqs_23(iwk,mciesp)                              
              do is=ik,mcnicb                                          
                iws=mciicb(is)                                         
                detqs_23=dqs_23(iws,mciesp)                            
c        d2wf_23=(ddw1_23(mciesp)*detqk_23*detqs_23*wsum_p12           
c     *  -dw11_23(mciesp)*detqk_23*sdw_23(is)                          
c     *  -we11_23(mciesp)*sddw1_23(is,ik)                              
c     *  -dw11_23(mciesp)*detqs_23*sdw_23(ik)                          
c     *  +2.d0*we11_23(mciesp)*sdw_23(ik)*                             
c     *  sdw_23(is)/wsum_p12)/(wsum_p12**2)                            
c        if(iws .eq. iwk)d2wf_23=d2wf_23+ddwf2_23                      
        hi12_23(iws,iwk)=hi12_23(iws,iwk)+
     *  d2wf_23(iws,iwk,mciesp)*e12p_23(mciesp)  
        hi12_23(iwk,iws)=hi12_23(iws,iwk)                         
              enddo                                                    
c                                                                      
c   3. calculate cross terms                                           
c                                                                      
       do j=1,mcnics                                                   
c         hi12_23(iwk,j)=hi12_23(iwk,j)+dwf_23(ik)*gi12pnt_23(j)       
c         hi12_23(j,iwk)=hi12_23(j,iwk)+dwf_23(ik)*gi12pnt_23(j)       
         hi12_23(iwk,j)=hi12_23(iwk,j)+
     *   dwf_23(mciesp,iwk)*gi12pnt_23(j) 
         hi12_23(j,iwk)=hi12_23(j,iwk)+
     *   dwf_23(mciesp,iwk)*gi12pnt_23(j)
       enddo                                                          
            enddo                                                     
c                                                                     
c            ddwf2_13 = ddw2_13(mciesp)/wsum_p12-                     
c     *  we11_13(mciesp)*sddw2_13/(wsum_p12*wsum_p12)                 
            do ik=1,mcnicb                                            
              iwk=mciicb(ik)                                          
              detqk_13=dqs_13(iwk,mciesp)                             
              do is=ik,mcnicb                                         
                iws=mciicb(is)                                        
                detqs_13=dqs_13(iws,mciesp)                           
c        d2wf_13=(ddw1_13(mciesp)*detqk_13*detqs_13*wsum_p12          
c     *  -dw11_13(mciesp)*detqk_13*sdw_13(is)                         
c     *  -we11_13(mciesp)*sddw1_13(is,ik)                             
c     *  -dw11_13(mciesp)*detqs_13*sdw_13(ik)                         
c     *  +2.d0*we11_13(mciesp)*sdw_13(ik)*                            
c     *  sdw_13(is)/wsum_p12)/(wsum_p12**2)                           
c        if(iws .eq. iwk)d2wf_13=d2wf_13+ddwf2_13                     
        hi12_13(iws,iwk)=hi12_13(iws,iwk)+
     *  d2wf_13(iws,iwk,mciesp)*e12p_13(mciesp)  
        hi12_13(iwk,iws)=hi12_13(iws,iwk)                            
              enddo                                                   
c                                                                     
c   3. calculate cross terms                                          
c                                                                     
       do j=1,mcnics                                                  
c         hi12_13(iwk,j)=hi12_13(iwk,j)+dwf_13(ik)*gi12pnt_13(j)        
c         hi12_13(j,iwk)=hi12_13(j,iwk)+dwf_13(ik)*gi12pnt_13(j)        
         hi12_13(iwk,j)=hi12_13(iwk,j)+
     *   dwf_13(mciesp,iwk)*gi12pnt_13(j)   
         hi12_13(j,iwk)=hi12_13(j,iwk)+
     *   dwf_13(mciesp,iwk)*gi12pnt_13(j)  
       enddo                                                            
            enddo                                                       
c                                                                       
c            ddwf2_123 = ddw2_123(mciesp)/wsum_p12-                     
c     *  we11_123(mciesp)*sddw2_123/(wsum_p12*wsum_p12)                 
            do ik=1,mcnicb                                              
              iwk=mciicb(ik)                                            
              detqk_123=dqs_123(iwk,mciesp)                             
              do is=ik,mcnicb                                           
                iws=mciicb(is)                                          
                detqs_123=dqs_123(iws,mciesp)                           
c        d2wf_123=(ddw1_123(mciesp)*detqk_123*detqs_123*wsum_p12        
c     *  -dw11_123(mciesp)*detqk_123*sdw_123(is)                        
c     *  -we11_123(mciesp)*sddw1_123(is,ik)                             
c     *  -dw11_123(mciesp)*detqs_123*sdw_123(ik)                        
c     *  +2.d0*we11_123(mciesp)*sdw_123(ik)*                            
c     *  sdw_123(is)/wsum_p12)/(wsum_p12**2)                            
c        if(iws .eq. iwk)d2wf_123=d2wf_123+ddwf2_123                    
        hi12_123(iws,iwk)=hi12_123(iws,iwk)+                            
     *  d2wf_123(iws,iwk,mciesp)*e12p_123(mciesp)                    
        hi12_123(iwk,iws)=hi12_123(iws,iwk)                             
              enddo                                                   
c                                                                     
c   3. calculate cross terms                                          
c                                                                     
       do j=1,mcnics                                                  
c         hi12_123(iwk,j)=hi12_123(iwk,j)+                            
c     *  dwf_123(ik)*gi12pnt_123(j)                                   
c         hi12_123(j,iwk)=hi12_123(j,iwk)+                            
c     *   dwf_123(ik)*gi12pnt_123(j)                                  
         hi12_123(iwk,j)=hi12_123(iwk,j)+                             
     *  dwf_123(mciesp,ik)*gi12pnt_123(j)    
         hi12_123(j,iwk)=hi12_123(j,iwk)+                             
     *   dwf_123(mciesp,ik)*gi12pnt_123(j)      
       enddo                                                          
            enddo                                                     
c                                                                     
c            ddwf2_132 = ddw2_132(mciesp)/wsum_p12-                   
c     *  we11_132(mciesp)*sddw2_132/(wsum_p12*wsum_p12)               
            do ik=1,mcnicb                                            
              iwk=mciicb(ik)                                          
              detqk_132=dqs_132(iwk,mciesp)                           
              do is=ik,mcnicb                                         
                iws=mciicb(is)                                        
                detqs_132=dqs_132(iws,mciesp)                         
c        d2wf_132=(ddw1_132(mciesp)*detqk_132*detqs_132*wsum_p12      
c     *  -dw11_132(mciesp)*detqk_132*sdw_132(is)                       
c     *  -we11_132(mciesp)*sddw1_132(is,ik)                            
c     *  -dw11_132(mciesp)*detqs_132*sdw_132(ik)                       
c     *  +2.d0*we11_132(mciesp)*sdw_132(ik)*                           
c     *  sdw_132(is)/wsum_p12)/(wsum_p12**2)                           
c        if(iws .eq. iwk)d2wf_132=d2wf_132+ddwf2_132                   
        hi12_132(iws,iwk)=hi12_132(iws,iwk)+                           
     *  d2wf_132(iws,iwk,mciesp)*e12p_132(mciesp)                    
        hi12_132(iwk,iws)=hi12_132(iws,iwk)                            
              enddo                                                    
c                                                                      
c   3. calculate cross terms                                           
c                                                                      
       do j=1,mcnics                                                   
c         hi12_132(iwk,j)=hi12_132(iwk,j)+                             
c     *   dwf_132(ik)*gi12pnt_132(j)                                   
c         hi12_132(j,iwk)=hi12_132(j,iwk)+                             
c     *   dwf_132(ik)*gi12pnt_132(j)                                   
         hi12_132(iwk,j)=hi12_132(iwk,j)+                              
     *   dwf_132(mciesp,ik)*gi12pnt_132(j)                            
         hi12_132(j,iwk)=hi12_132(j,iwk)+                              
     *   dwf_132(mciesp,ik)*gi12pnt_132(j)                           
       enddo                                                           
            enddo                                                      
c 
c              do ik=1,mcnicb                                          
c              iwk=mciicb(ik)                                          
c              do is=ik,mcnicb                                         
c                iws=mciicb(is)                                        
c        hi12(iws,iwk)=hi12_E(iws,iwk)+hi12_12(iws,iwk)+               
c     *  hi12_23(iws,iwk)+hi12_13(iws,iwk)+                            
c     *  hi12_123(iws,iwk)+hi12_132(iws,iwk)                           
c        hi12(iwk,iws)=hi12(iws,iwk)                                   
c              enddo                                                   
c              do j=1,mcnics                                           
c              hi12(iwk,j)=hi12_E(iwk,j)+hi12_12(iwk,j)+               
c     *  hi12_23(iwk,j)+hi12_13(iwk,j)+                                
c     *  hi12_123(iwk,j)+hi12_132(iwk,j)                               
c              enddo                                                     
c              enddo     
c sum_i=1^{6}             
              do i=1,mcnics
        hi12(i,i)=hi12_E(i,i)+hi12_12(i,i)+              
     *  hi12_23(i,i)+hi12_13(i,i)+                           
     *  hi12_123(i,i)+hi12_132(i,i)                          
              enddo   
c sum_i=1^{6} off-diagonal
              do i=1,mcnics
              do j=1,mcnics                                          
              hi12(i,j)=hi12_E(i,j)+hi12_12(i,j)+              
     *  hi12_23(i,j)+hi12_13(i,j)+                               
     *  hi12_123(i,j)+hi12_132(i,j)                              
              enddo
              enddo
          endif                                                         
c        endif  
c     end of loop over number of shepard points                         
c                                                                       
 1000 continue 
c        write (*,*) "Ggi12(k)=", gi12(1)
c              
      return                                                            
      end                                                               
c***********************************************************************
c     mcv12is2
c***********************************************************************
c
      subroutine mcv12is2(e12,gi12,hi12,itypec)
c
c     This subroutine is a modified version of mcv12i subroutine.
c     It returns symmetrized V12, its gradient and Hessian.
c     The formalism is described in 'Tishchenko & Truhlar, JCTC 2007, 3, 938-948'.    
c     The current version only supports systems with n = 3 identical nuclei.
c     (O.T. November 2006; modifications June 2007)
c
      implicit double precision (a-h, o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      dimension dqs(mcmics,mcmesp+2)
      dimension dqs_12(mcmics,mcmesp+2)
      dimension dqs_23(mcmics,mcmesp+2)
      dimension dqs_13(mcmics,mcmesp+2)
      dimension dqs_123(mcmics,mcmesp+2)
      dimension dqs_132(mcmics,mcmesp+2)
      dimension w_p12(mcmesp*6+12)
      dimension w(mcmesp+2)
      dimension we11(mcmesp)                                          
      dimension we11_12(mcmesp)                                       
      dimension we11_23(mcmesp)                                       
      dimension we11_13(mcmesp)                                       
      dimension we11_123(mcmesp)                                      
      dimension we11_132(mcmesp)                                      
       dimension uterm(mcmesp)
       dimension uterm_12(mcmesp)
       dimension uterm_13(mcmesp)
       dimension uterm_23(mcmesp)
       dimension uterm_123(mcmesp)
       dimension uterm_132(mcmesp)
c
      dimension indexw(mcmesp,6)
c
      dimension e12pnt(mcmesp),e12pf(mcmesp),e12p(mcmesp)
      dimension e12pnt_12(mcmesp),e12pf_12(mcmesp),             
     *          e12p_12(mcmesp)                                   
      dimension e12pnt_23(mcmesp),e12pf_23(mcmesp),             
     *          e12p_23(mcmesp)                                   
      dimension e12pnt_13(mcmesp),e12pf_13(mcmesp),             
     *          e12p_13(mcmesp)                                   
      dimension e12pnt_123(mcmesp),e12pf_123(mcmesp),           
     *          e12p_123(mcmesp)                                  
      dimension e12pnt_132(mcmesp),e12pf_132(mcmesp),           
     *          e12p_132(mcmesp)                                  
      dimension gi12pnt(mcmics),gi12(mcmics),hi12(mcmics,mcmics)
      dimension gi12_E(mcmics),hi12_E(mcmics,mcmics)               
      dimension gi12pnt_12(mcmics),gi12_12(mcmics),                
     * hi12_12(mcmics,mcmics)                                      
      dimension gi12pnt_23(mcmics),gi12_23(mcmics),                
     * hi12_23(mcmics,mcmics)                                      
      dimension gi12pnt_13(mcmics),gi12_13(mcmics),                
     * hi12_13(mcmics,mcmics)                                      
      dimension gi12pnt_123(mcmics),gi12_123(mcmics),              
     * hi12_123(mcmics,mcmics)                                     
      dimension gi12pnt_132(mcmics),gi12_132(mcmics),              
     * hi12_132(mcmics,mcmics)                                     
      dimension wrk(mcmics),wrk1(mcmics)
      dimension wrk_12(mcmics),wrk1_12(mcmics)                          
      dimension wrk_23(mcmics),wrk1_23(mcmics)                          
      dimension wrk_13(mcmics),wrk1_13(mcmics)                          
      dimension wrk_123(mcmics),wrk1_123(mcmics)                        
      dimension wrk_132(mcmics),wrk1_132(mcmics)                        
      dimension  dwf(mcmesp*6+12,mcmicd)
      dimension  dwf_12(mcmesp+2,mcmicd)
      dimension  dwf_E(mcmesp+2,mcmicd)
      dimension  dwf_23(mcmesp+2,mcmicd)
      dimension  dwf_13(mcmesp+2,mcmicd)
      dimension  dwf_123(mcmesp+2,mcmicd)
      dimension  dwf_132(mcmesp+2,mcmicd)
      dimension  d2wf(mcmicd,mcmicd,mcmesp*6+12)
      dimension  d2wf_E(mcmicd,mcmicd,mcmesp+2)
      dimension  d2wf_12(mcmicd,mcmicd,mcmesp+2)
      dimension  d2wf_23(mcmicd,mcmicd,mcmesp+2)
      dimension  d2wf_13(mcmicd,mcmicd,mcmesp+2)
      dimension  d2wf_123(mcmicd,mcmicd,mcmesp+2)
      dimension  d2wf_132(mcmicd,mcmicd,mcmesp+2)
c
      zero = 0.d0
c 
c     zero out Shepard variables
c
c      do i=1,mcmics
c        do j=1,mcmesp+2
       do j=1,mcmesp+2
         do i=1,mcmics
          dqs(i,j) =  0.d0
          dqs_12(i,j) =  0.d0
          dqs_23(i,j) =  0.d0
          dqs_13(i,j) =  0.d0
          dqs_123(i,j) =  0.d0
          dqs_132(i,j) =  0.d0
        enddo
      enddo
      do i=1,mcmesp+2
      do j=1,mcmicd
      dwf_E(i,j)=0.d0
      dwf_12(i,j)=0.d0
      dwf_23(i,j)=0.d0
      dwf_13(i,j)=0.d0
      dwf_123(i,j)=0.d0
      dwf_132(i,j)=0.d0
      enddo
      enddo
      do k=1,mcmesp+2
      do i=1,mcmicd
      do j=1,mcmicd
      d2wf_E(i,j,k)=0.d0
      d2wf_12(i,j,k)=0.d0
      d2wf_23(i,j,k)=0.d0
      d2wf_13(i,j,k)=0.d0
      d2wf_123(i,j,k)=0.d0
      d2wf_132(i,j,k)=0.d0
      enddo
      enddo
      enddo
c      do i=1,mcmesp+2
      do i=1,mcmesp
        w(i)   =  0.d0
        e12pnt(i) = 0.0d0
        e12pf(i) = 0.0d0
        e12p(i) = 0.0d0
        e12pnt_12(i) = 0.0d0                                            
        e12pf_12(i) = 0.0d0                                             
        e12p_12(i) = 0.0d0                                              
        w_p12(i)   =  0.d0                                              
        e12pnt_23(i) = 0.0d0                                            
        e12pf_23(i) = 0.0d0                                             
        e12p_23(i) = 0.0d0                                              
        e12pnt_13(i) = 0.0d0                                            
        e12pf_13(i) = 0.0d0                                             
        e12p_13(i) = 0.0d0                                              
        e12pnt_123(i) = 0.0d0                                           
        e12pf_123(i) = 0.0d0                                            
        e12p_123(i) = 0.0d0                                             
        e12pnt_132(i) = 0.0d0                                           
        e12pf_132(i) = 0.0d0                                            
        e12p_132(i) = 0.0d0                                             
          do j=1,mcmics
            dwf(i,j)  = 0.d0
          enddo
      enddo       
       do i=1,mcmesp                                                    
        we11(i)=0.0d0                                                   
        we11_12(i)=0.0d0                                                
        we11_23(i)=0.0d0                                                
        we11_13(i)=0.0d0                                                
        we11_123(i)=0.0d0                                               
        we11_132(i)=0.0d0                                               
        enddo     
      do i = 1, mcmics
         do j = 1, mcmics
            hi12(i,j) = zero
            hi12_E(i,j) = zero
            hi12_12(i,j) = zero                                         
            hi12_23(i,j) = zero                                         
            hi12_13(i,j) = zero                                         
            hi12_123(i,j) = zero                                        
            hi12_132(i,j) = zero                                        
         end do
         gi12(i)=zero
         gi12_E(i)=zero                                                 
         gi12_12(i)=zero                                                
         gi12_23(i)=zero                                                
         gi12_13(i)=zero                                                
         gi12_123(i)=zero                                               
         gi12_132(i)=zero                                               
      end do
       do i=1,6
       do j=1,mcmesp
        indexw(i,j)=0
       enddo
       enddo
      do i=1,mcmics                                                     
        gi12pnt(i)  = 0.d0                                              
        gi12pnt_12(i)  = 0.d0                                           
        gi12pnt_23(i)  = 0.d0                                           
        gi12pnt_13(i)  = 0.d0                                           
        gi12pnt_123(i)  = 0.d0                                          
        gi12pnt_132(i)  = 0.d0                                          
      enddo
c
       e12 = zero
       e12_12 = zero                                                    
       e12_23 = zero                                                    
       e12_13 = zero                                                    
       e12_123 = zero                                                   
       e12_132 = zero                                                   
             e12a= zero                                                 
             e12b= zero                                                 
             e12c= zero                                                 
             e12d= zero                                                 
             e12e= zero                                                 
             e12f= zero                                                 
c
c     calculate the displacement in internal coordinates used for
c     generalized distances
c
       do j=1,mcnesp+2
         do i=1,mcnics
          dqs(i,j)=qs(i)-qs0(i,j)
          dqs_12(i,j)=qs(i)-qs0_12(i,j)                                 
          dqs_23(i,j)=qs(i)-qs0_23(i,j)                                 
          dqs_13(i,j)=qs(i)-qs0_13(i,j)                                 
          dqs_123(i,j)=qs(i)-qs0_123(i,j)                               
          dqs_132(i,j)=qs(i)-qs0_132(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
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas                 
               if (dqs_12(i,j).lt.-fpi) then                            
                   dqs_12(i,j) = dqs_12(i,j)+2.0d0*fpi                  
               elseif (dqs_12(i,j).gt.fpi) then                         
                   dqs_12(i,j) = dqs_12(i,j)-2.0d0*fpi                  
               endif                                                    
            enddo                                                       
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas                 
               if (dqs_23(i,j).lt.-fpi) then                            
                   dqs_23(i,j) = dqs_23(i,j)+2.0d0*fpi                  
               elseif (dqs_23(i,j).gt.fpi) then                         
                   dqs_23(i,j) = dqs_23(i,j)-2.0d0*fpi                  
               endif                                                    
            enddo                                                       
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas                 
               if (dqs_13(i,j).lt.-fpi) then                            
                   dqs_13(i,j) = dqs_13(i,j)+2.0d0*fpi                  
               elseif (dqs_13(i,j).gt.fpi) then                         
                   dqs_13(i,j) = dqs_13(i,j)-2.0d0*fpi                  
               endif                                                    
            enddo                                                       
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas                 
               if (dqs_123(i,j).lt.-fpi) then                           
                   dqs_123(i,j) = dqs_123(i,j)+2.0d0*fpi                
               elseif (dqs_123(i,j).gt.fpi) then                        
                   dqs_123(i,j) = dqs_123(i,j)-2.0d0*fpi                
               endif                                                    
            enddo                                                       
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas                 
               if (dqs_132(i,j).lt.-fpi) then                           
                   dqs_132(i,j) = dqs_132(i,j)+2.0d0*fpi                
               elseif (dqs_132(i,j).gt.fpi) then                        
                   dqs_132(i,j) = dqs_132(i,j)-2.0d0*fpi                
               endif                                                    
            enddo                                                       
         endif
      enddo
c
c get weights
c
       call mcswtsnum(w_p12,dwf,d2wf,itypec)
c
          j = 0
c
c  loop over all (m!N) Shepard points to select weights+derivatives for the ES points
c  and leave out the data for MM structures 1 and 2.                      
           k=2                                                          
c                                                                       
           do i=0,5                                                     
           do j=1,mcnesp                                                
           indexw(j,i+1)=mcnesp*i+k*i+j                                 
           enddo                                                        
           enddo                                                        
c                                                                       
          do j = 1, mcnesp                                              
          we11(j)=w_p12(indexw(j,1))                                    
          do i=1,mcnicd
          dwf_E(j,i)=dwf(indexw(j,1),i)
          do k=1,mcnicd
          d2wf_E(i,k,j)=d2wf(i,k,indexw(j,1))
          enddo
          enddo
c          dw11(j)=dw_p12(indexw(j,1))                                  
c          ddw1_E(j)=ddw1_p12(indexw(j,1))                              
c          ddw2_E(j)=ddw2_p12(indexw(j,1))                              
          enddo                                                         
          do j = 1, mcnesp                                              
          we11_12(j)=w_p12(indexw(j,2))                                 
          do i=1,mcnicd
          dwf_12(j,i)=dwf(indexw(j,2),i)
          do k=1,mcnicd
          d2wf_12(i,k,j)=d2wf(i,k,indexw(j,2))
          enddo
          enddo
c          dw11_12(j)=dw_p12(indexw(j,2))                              
c          ddw1_12(j)=ddw1_p12(indexw(j,2))                            
c          ddw2_12(j)=ddw2_p12(indexw(j,2))                            
          enddo                                                        
          do j = 1, mcnesp                                             
          we11_23(j)=w_p12(indexw(j,3))                                
          do i=1,mcnicd
          dwf_23(j,i)=dwf(indexw(j,3),i)
          do k=1,mcnicd
          d2wf_23(i,k,j)=d2wf(i,k,indexw(j,3))
          enddo
          enddo
c          dw11_23(j)=dw_p12(indexw(j,3))                              
c          ddw1_23(j)=ddw1_p12(indexw(j,3))                             
c          ddw2_23(j)=ddw2_p12(indexw(j,3))                            
          enddo                                                        
          do j = 1, mcnesp                                             
          we11_13(j)=w_p12(indexw(j,4))                                
          do i=1,mcnicd
          dwf_13(j,i)=dwf(indexw(j,4),i)
          do k=1,mcnicd
          d2wf_13(i,k,j)=d2wf(i,k,indexw(j,4))
          enddo
          enddo
c          dw11_13(j)=dw_p12(indexw(j,4))                             
c          ddw1_13(j)=ddw1_p12(indexw(j,4))                           
c          ddw2_13(j)=ddw2_p12(indexw(j,4))                           
          enddo                                                       
          do j = 1, mcnesp                                            
          we11_123(j)=w_p12(indexw(j,5))                              
          do i=1,mcnicd
          dwf_123(j,i)=dwf(indexw(j,5),i)
          do k=1,mcnicd
          d2wf_123(i,k,j)=d2wf(i,k,indexw(j,5))
          enddo
          enddo
c          dw11_123(j)=dw_p12(indexw(j,5))                             
c          ddw1_123(j)=ddw1_p12(indexw(j,5))                           
c          ddw2_123(j)=ddw2_p12(indexw(j,5))                           
          enddo                                                        
          do j = 1, mcnesp                                             
          we11_132(j)=w_p12(indexw(j,6))                               
          do i=1,mcnicd
          dwf_132(j,i)=dwf(indexw(j,6),i)
          do k=1,mcnicd
          d2wf_132(i,k,j)=d2wf(i,k,indexw(j,6))
          enddo
          enddo
c          dw11_132(j)=dw_p12(indexw(j,6))                            
c          ddw1_132(j)=ddw1_p12(indexw(j,6))                          
c          ddw2_132(j)=ddw2_p12(indexw(j,6))                          
          enddo                                                       
          do j = 1, mcnesp                                            
          enddo  
c          
       do 1000 mciesp=1,mcnesp                                                           
c
          btrm=0.d0
          ctrm=0.d0
          qtrm=0.d0
          btrm_12=0.d0                                                  
          btrm_23=0.d0                                                  
          btrm_13=0.d0                                                  
          btrm_123=0.d0                                                 
          btrm_132=0.d0                                                 
          ctrm_12=0.d0                                                  
          ctrm_23=0.d0                                                  
          ctrm_13=0.d0                                                  
          ctrm_123=0.d0                                                 
          ctrm_132=0.d0                                                 
          qtrm_12=0.d0                                                  
          be12=0.d0                                                     
          be12_12=0.d0                                                  
          be12_23=0.d0                                                  
          be12_13=0.d0                                                  
          be12_123=0.d0                                                 
          be12_132=0.d0                                                 
c
          do i=1,mcnics
            wrk(i) =0.d0
            wrk_12(i) =0.d0                                             
            wrk_23(i) =0.d0                                             
            wrk_13(i) =0.d0                                             
            wrk_123(i) =0.d0                                            
            wrk_132(i) =0.d0                                            
            btrm=btrm+bevbm(i,mciesp)*dqs(i,mciesp)                     
            btrm_12=btrm_12+bevbm_12(i,mciesp)*dqs_12(i,mciesp)          
            btrm_23=btrm_23+bevbm_23(i,mciesp)*dqs_23(i,mciesp)         
            btrm_13=btrm_13+bevbm_13(i,mciesp)*dqs_13(i,mciesp)         
            btrm_123=btrm_123+bevbm_123(i,mciesp)*dqs_123(i,mciesp)     
            btrm_132=btrm_132+bevbm_132(i,mciesp)*dqs_132(i,mciesp)     
            do j=1,mcnics
              wrk(i)=wrk(i)+dqs(j,mciesp)*cevbm(i,j,mciesp)
          wrk_12(i)=wrk_12(i)+dqs_12(j,mciesp)*cevbm_12(i,j,mciesp)     
          wrk_23(i)=wrk_23(i)+dqs_23(j,mciesp)*cevbm_23(i,j,mciesp)     
          wrk_13(i)=wrk_13(i)+dqs_13(j,mciesp)*cevbm_13(i,j,mciesp)     
          wrk_123(i)=wrk_123(i)+dqs_123(j,mciesp)*cevbm_123(i,j,mciesp) 
          wrk_132(i)=wrk_132(i)+dqs_132(j,mciesp)*cevbm_132(i,j,mciesp) 
            enddo
            ctrm=ctrm+dqs(i,mciesp)*wrk(i)
            ctrm_12=ctrm_12+dqs_12(i,mciesp)*wrk_12(i)                  
            ctrm_23=ctrm_23+dqs_23(i,mciesp)*wrk_23(i)                  
            ctrm_13=ctrm_13+dqs_13(i,mciesp)*wrk_13(i)                  
            ctrm_123=ctrm_123+dqs_123(i,mciesp)*wrk_123(i)              
            ctrm_132=ctrm_132+dqs_132(i,mciesp)*wrk_132(i)              
          enddo
c
c     Added to avoid negative values for V12**2 term, 4/14/99 by Y. Kim
c
c           delta = 0.00016d0
c           udelta = 0.0000000256d0
c           unn = 2.d0
          be12 = 1.d0+btrm+0.5d0*ctrm
          be12_12 = 1.d0+btrm_12+0.5d0*ctrm_12                            
          be12_23 = 1.d0+btrm_23+0.5d0*ctrm_23                             
          be12_13 = 1.d0+btrm_13+0.5d0*ctrm_13                             
          be12_123 = 1.d0+btrm_123+0.5d0*ctrm_123                         
          be12_132 = 1.d0+btrm_132+0.5d0*ctrm_132                         
          e12p(mciesp) = aevbm(mciesp)*be12
          e12p_12(mciesp) = aevbm(mciesp)*be12_12                       
          e12p_23(mciesp) = aevbm(mciesp)*be12_23                       
          e12p_13(mciesp) = aevbm(mciesp)*be12_13                       
          e12p_123(mciesp) = aevbm(mciesp)*be12_123                     
          e12p_132(mciesp) = aevbm(mciesp)*be12_132                     
c
ccc          if (e12p(mciesp).gt.0.0d0) then
cc            fixf = dexp(-delta/e12p(mciesp))
cc              fixf = 1.d0/(1.d0+(delta/e12p(mciesp))**unn)
ccc              uterm(mciesp)=udelta/e12p(mciesp)                          1206OT08
ccc              fixf = 1.d0/(1.d0+(uterm(mciesp))**unn)                    1206OT08
ccc          else
ccc            fixf = 0.0d0
ccc          endif
ccc          if (e12p_12(mciesp).gt.0.0d0) then                            
cc            fixf_12 = dexp(-delta/e12p_12(mciesp))                      
cc              fixf_12 = 1.d0/(1.d0+(delta/e12p_12(mciesp))**unn)
ccc              uterm_12(mciesp)=udelta/e12p_12(mciesp)                          1206OT08
ccc              fixf_12 = 1.d0/(1.d0+(uterm_12(mciesp))**unn)                    1206OT08
ccc          else                                                          
ccc            fixf_12 = 0.0d0                                             
ccc          endif                                                         
ccc          if (e12p_23(mciesp).gt.0.0d0) then                            
cc            fixf_23 = dexp(-delta/e12p_23(mciesp))                      
cc             fixf_23 = 1.d0/(1.d0+(delta/e12p_23(mciesp))**unn)
ccc              uterm_23(mciesp)=udelta/e12p_23(mciesp)                          1206OT08
ccc              fixf_23 = 1.d0/(1.d0+(uterm_23(mciesp))**unn)                    1206OT08
ccc          else                                                          
ccc            fixf_23 = 0.0d0                                             
ccc          endif                                                         
ccc          if (e12p_13(mciesp).gt.0.0d0) then                            
cc            fixf_13 = dexp(-delta/e12p_13(mciesp))                      
cc            fixf_13 = 1.d0/(1.d0+(delta/e12p_13(mciesp))**unn)
ccc              uterm_13(mciesp)=udelta/e12p_13(mciesp)                          1206OT08
ccc              fixf_13 = 1.d0/(1.d0+(uterm_13(mciesp))**unn)                    1206OT08
ccc          else                                                          
ccc            fixf_13 = 0.0d0                                             
ccc          endif                                                         
ccc          if (e12p_123(mciesp).gt.0.0d0) then                           
cc            fixf_123 = dexp(-delta/e12p_123(mciesp))                    
cc            fixf_123 = 1.d0/(1.d0+(delta/e12p_123(mciesp))**unn)
ccc              uterm_123(mciesp)=udelta/e12p_123(mciesp)                          1206OT08
ccc              fixf_123 = 1.d0/(1.d0+(uterm_123(mciesp))**unn)                    1206OT08
ccc          else                                                          
ccc            fixf_123 = 0.0d0                                            
ccc          endif                                                         
ccc          if (e12p_132(mciesp).gt.0.0d0) then                           
cc            fixf_132 = dexp(-delta/e12p_132(mciesp))                    
cc           fixf_132 = 1.d0/(1.d0+(delta/e12p_132(mciesp))**unn)
ccc              uterm_132(mciesp)=udelta/e12p_132(mciesp)                          1206OT08
ccc              fixf_132 = 1.d0/(1.d0+(uterm_132(mciesp))**unn)                    1206OT08
ccc          else                                                          
ccc            fixf_132 = 0.0d0                                            
ccc          endif                                                         
ccc          e12pf(mciesp) = e12p(mciesp)*fixf                             
ccc          e12pf_12(mciesp) = e12p_12(mciesp)*fixf_12                    
ccc          e12pf_23(mciesp) = e12p_23(mciesp)*fixf_23                    
ccc          e12pf_13(mciesp) = e12p_13(mciesp)*fixf_13                    
ccc          e12pf_123(mciesp) = e12p_123(mciesp)*fixf_123                 
ccc          e12pf_132(mciesp) = e12p_132(mciesp)*fixf_132                 
c
ccc          e12pnt(mciesp) = dsqrt(e12pf(mciesp))                         
ccc          e12pnt_12(mciesp) = dsqrt(e12pf_12(mciesp))                   
ccc          e12pnt_23(mciesp) = dsqrt(e12pf_23(mciesp))                   
ccc          e12pnt_13(mciesp) = dsqrt(e12pf_13(mciesp))                   
ccc          e12pnt_123(mciesp) = dsqrt(e12pf_123(mciesp))                 
ccc          e12pnt_132(mciesp) = dsqrt(e12pf_132(mciesp))                 
c
c          write (*,*) "WW", we11(mciesp),we11_12(mciesp),
c     *    we11_23(mciesp),we11_13(mciesp),we11_123(mciesp),
c     *    we11_132(mciesp),mciesp
c
        e12a = e12a+we11(mciesp)*e12p(mciesp)        
        e12b = e12b+we11_12(mciesp)*e12p_12(mciesp)    
        e12c = e12c+we11_23(mciesp)*e12p_23(mciesp)     
        e12d = e12d+we11_13(mciesp)*e12p_13(mciesp)     
        e12e = e12e+we11_123(mciesp)*e12p_123(mciesp)     
        e12f = e12f+we11_132(mciesp)*e12p_132(mciesp)     
        e12 = e12a + e12b + e12c + e12d + e12e +e12f
c
c------------------end of e12------------------------------------
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
            wrk1s_12 = 0.d0                                             
            wrk1s_23 = 0.d0                                             
            wrk1s_13 = 0.d0                                             
            wrk1s_123 = 0.d0                                            
            wrk1s_132 = 0.d0                                            
              do k1 = 1,mcnics                                          
                wrk1s = wrk1s+cevbm(k1,k,mciesp)*dqs(k1,mciesp)
                wrk1s_12 = wrk1s_12+                                    
     *    cevbm_12(k1,k,mciesp)*dqs_12(k1,mciesp)                       
                wrk1s_23 = wrk1s_23+                                    
     *    cevbm_23(k1,k,mciesp)*dqs_23(k1,mciesp)                       
                wrk1s_13 = wrk1s_13+                                    
     *    cevbm_13(k1,k,mciesp)*dqs_13(k1,mciesp)                       
                wrk1s_123 = wrk1s_123+                                  
     *    cevbm_123(k1,k,mciesp)*dqs_123(k1,mciesp)                     
                wrk1s_132 = wrk1s_132+                                  
     *    cevbm_132(k1,k,mciesp)*dqs_132(k1,mciesp)                     
              enddo                                                     
            wrk1(k) = wrk1s                                             
            wrk1_12(k) = wrk1s_12                                       
            wrk1_23(k) = wrk1s_23                                       
            wrk1_13(k) = wrk1s_13                                       
            wrk1_123(k) = wrk1s_123                                     
            wrk1_132(k) = wrk1s_132                                     
          enddo                                                         
          do k=1,mcnics    
c                                             
                gi12pnt(k)=aevbm(mciesp)*(bevbm(k,mciesp)+
     *           0.5d0*(wrk(k)+wrk1(k)))
c
                gi12pnt_12(k)=aevbm(mciesp)*(bevbm_12(k,mciesp)+
     *           0.5d0*(wrk_12(k)+wrk1_12(k)))
c                                                                       
                gi12pnt_23(k)=aevbm(mciesp)*(bevbm_23(k,mciesp)+
     *           0.5d0*(wrk_23(k)+wrk1_23(k)))
c                                                                       
                gi12pnt_13(k)=aevbm(mciesp)*(bevbm_13(k,mciesp)+
     *           0.5d0*(wrk_13(k)+wrk1_13(k)))
c                                                                       
                gi12pnt_123(k)=aevbm(mciesp)*(bevbm_123(k,mciesp)+
     *           0.5d0*(wrk_123(k)+wrk1_123(k)))
c                                                                       
                gi12pnt_132(k)=aevbm(mciesp)*(bevbm_132(k,mciesp)+
     *           0.5d0*(wrk_132(k)+wrk1_132(k)))
c                                                                       
          enddo
c                                                                       
c     weight the gradient                                               
c                                                                       
          do k=1,mcnics                                                 
            gi12_E(k) = gi12_E(k) + gi12pnt(k)*we11(mciesp)
            gi12_12(k) = gi12_12(k) +                                  
     *     gi12pnt_12(k)*we11_12(mciesp)
           gi12_23(k) = gi12_23(k) +                                   
     *     gi12pnt_23(k)*we11_23(mciesp)
           gi12_13(k) = gi12_13(k) +                                   
     *     gi12pnt_13(k)*we11_13(mciesp)
           gi12_123(k) = gi12_123(k) +                                 
     *     gi12pnt_123(k)*we11_123(mciesp)
           gi12_132(k) = gi12_132(k) +                                 
     *     gi12pnt_132(k)*we11_132(mciesp)
          enddo
c            do k=1,mcnics
c         gi12(k)=gi12_E(k)+gi12_12(k)+gi12_23(k)+
c     &   gi12_13(k)+gi12_123(k)+gi12_132(k)  
c            enddo
c 
c     if shepard interpolation is used, calculate dwf(k)=dW(i)/dqs(k)
c
        if (mcimre.eq.2) then
        do kw=1,mcnics
        gi12_E(kw)=gi12_E(kw)+e12p(mciesp)*dwf_E(mciesp,kw)
c
        gi12_12(kw)=gi12_12(kw)+e12p_12(mciesp)*dwf_12(mciesp,kw)
c              
        gi12_23(kw)=gi12_23(kw)+e12p_23(mciesp)*dwf_23(mciesp,kw)
c               
        gi12_13(kw)=gi12_13(kw)+e12p_13(mciesp)*dwf_13(mciesp,kw)
c               
        gi12_123(kw)=gi12_123(kw)+
     &   e12p_123(mciesp)*dwf_123(mciesp,kw)
c               
        gi12_132(kw)=gi12_132(kw)+
     &   e12p_132(mciesp)*dwf_132(mciesp,kw)
c              
        enddo
        do k=1,mcnics
         gi12(k)=gi12_E(k)+gi12_12(k)+gi12_23(k)+
     &   gi12_13(k)+gi12_123(k)+gi12_132(k)  
        enddo
        endif
c
c----------------- end of first derivative calculations ------
c
c------------------ begin calculating the hessian -----
c
c     first check if it is necessary (itypec = 1)
c
          if (itypec .eq. 2) goto 1000
c
c   1. calculate dd(e12(i))/(dqs(k)dqs(s))*w(i)
c
            do ik=1,mcnics
              do is=ik,mcnics
                  hi12_E(is,ik)=hi12_E(is,ik)+aevbm(mciesp)*
     *            0.5d0*(cevbm(is,ik,mciesp)+
     *            cevbm(ik,is,mciesp))*we11(mciesp)
                  hi12_E(ik,is)=hi12_E(is,ik)
              enddo
            enddo
c
            do ik=1,mcnics                                              
              do is=ik,mcnics                                           
                  hi12_12(is,ik)=hi12_12(is,ik)+aevbm(mciesp)*
     *            0.5d0*(cevbm_12(is,ik,mciesp)+
     *            cevbm_12(ik,is,mciesp))*we11_12(mciesp)
                  hi12_12(ik,is)=hi12_12(is,ik)
              enddo                                                     
            enddo                                                       
            do ik=1,mcnics                                              
              do is=ik,mcnics                                           
                  hi12_23(is,ik)=hi12_23(is,ik)+aevbm(mciesp)*
     *            0.5d0*(cevbm_23(is,ik,mciesp)+
     *            cevbm_23(ik,is,mciesp))*we11_23(mciesp)
                  hi12_23(ik,is)=hi12_23(is,ik)
              enddo                                                     
            enddo                                                       
c                                                                       
            do ik=1,mcnics                                              
              do is=ik,mcnics                                           
                  hi12_13(is,ik)=hi12_13(is,ik)+aevbm(mciesp)*
     *            0.5d0*(cevbm_13(is,ik,mciesp)+
     *            cevbm_13(ik,is,mciesp))*we11_13(mciesp)
                  hi12_13(ik,is)=hi12_13(is,ik)
              enddo                                                     
            enddo                                                       
c                                                                       
            do ik=1,mcnics                                              
              do is=ik,mcnics                                           
                  hi12_123(is,ik)=hi12_123(is,ik)+aevbm(mciesp)*
     *            0.5d0*(cevbm_123(is,ik,mciesp)+
     *            cevbm_123(ik,is,mciesp))*we11_123(mciesp)
                  hi12_123(ik,is)=hi12_123(is,ik)
              enddo                                                     
            enddo                                                       
c                                                                       
            do ik=1,mcnics                                              
              do is=ik,mcnics                                           
                  hi12_132(is,ik)=hi12_132(is,ik)+aevbm(mciesp)*
     *            0.5d0*(cevbm_132(is,ik,mciesp)+
     *            cevbm_132(ik,is,mciesp))*we11_132(mciesp)
                  hi12_132(ik,is)=hi12_132(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_E(iws,iwk)=hi12_E(iws,iwk)+
     *          d2wf_E(iws,iwk,mciesp)*e12p(mciesp)         
                hi12_E(iwk,iws)=hi12_E(iws,iwk)                             
              enddo        
c                                                                       
c   3. calculate cross terms                                            
c                                                                       
              do j=1,mcnics                                             
                hi12_E(iwk,j)=hi12_E(iwk,j)+
     *          dwf_E(mciesp,iwk)*gi12pnt(j)
                hi12_E(j,iwk)=hi12_E(j,iwk)+
     *          dwf_E(mciesp,iwk)*gi12pnt(j)
              enddo                                                     
             enddo                                                      
c                                                                       
            do iwk=1,mcnics
              do iws=ik,mcnics
        hi12_12(iws,iwk)=hi12_12(iws,iwk)+
     *  d2wf_12(iws,iwk,mciesp)*e12p_12(mciesp)  
        hi12_12(iwk,iws)=hi12_12(iws,iwk)                              
              enddo                                                    
c                                                                      
c   3. calculate cross terms                                           
c                                                                      
       do j=1,mcnics                                                   
         hi12_12(iwk,j)=hi12_12(iwk,j)+
     *   dwf_12(mciesp,iwk)*gi12pnt_12(j)   
         hi12_12(j,iwk)=hi12_12(j,iwk)+
     *   dwf_12(mciesp,iwk)*gi12pnt_12(j)  
       enddo                                                           
            enddo                                                      
c                                                                      
            do iwk=1,mcnics
              do iws=iwk,mcnics
        hi12_23(iws,iwk)=hi12_23(iws,iwk)+
     *  d2wf_23(iws,iwk,mciesp)*e12p_23(mciesp)  
        hi12_23(iwk,iws)=hi12_23(iws,iwk)                         
              enddo                                                    
c                                                                      
c   3. calculate cross terms                                           
c                                                                      
       do j=1,mcnics                                                   
         hi12_23(iwk,j)=hi12_23(iwk,j)+
     *   dwf_23(mciesp,iwk)*gi12pnt_23(j) 
         hi12_23(j,iwk)=hi12_23(j,iwk)+
     *   dwf_23(mciesp,iwk)*gi12pnt_23(j)
       enddo                                                          
            enddo                                                     
c                                                                     
            do iwk=1,mcnics
              do iws=iwk,mcnics
        hi12_13(iws,iwk)=hi12_13(iws,iwk)+
     *  d2wf_13(iws,iwk,mciesp)*e12p_13(mciesp)  
        hi12_13(iwk,iws)=hi12_13(iws,iwk)                            
              enddo                                                   
c                                                                     
c   3. calculate cross terms                                          
c                                                                     
       do j=1,mcnics                                                  
         hi12_13(iwk,j)=hi12_13(iwk,j)+
     *   dwf_13(mciesp,iwk)*gi12pnt_13(j)   
         hi12_13(j,iwk)=hi12_13(j,iwk)+
     *   dwf_13(mciesp,iwk)*gi12pnt_13(j)  
       enddo                                                            
            enddo                                                       
c                                                                       
            do iwk=1,mcnics
              do iws=iwk,mcnics
        hi12_123(iws,iwk)=hi12_123(iws,iwk)+                            
     *  d2wf_123(iws,iwk,mciesp)*e12p_123(mciesp)                    
        hi12_123(iwk,iws)=hi12_123(iws,iwk)                             
              enddo                                                   
c                                                                     
c   3. calculate cross terms                                          
c                                                                     
       do j=1,mcnics                                                  
         hi12_123(iwk,j)=hi12_123(iwk,j)+                             
     *  dwf_123(mciesp,ik)*gi12pnt_123(j)    
         hi12_123(j,iwk)=hi12_123(j,iwk)+                             
     *   dwf_123(mciesp,ik)*gi12pnt_123(j)      
       enddo                                                          
            enddo                                                     
c                                                                     
            do iwk=1,mcnics
              do iws=iwk,mcnics
        hi12_132(iws,iwk)=hi12_132(iws,iwk)+                           
     *  d2wf_132(iws,iwk,mciesp)*e12p_132(mciesp)                    
        hi12_132(iwk,iws)=hi12_132(iws,iwk)                            
              enddo                                                    
c                                                                      
c   3. calculate cross terms                                           
c                                                                      
       do j=1,mcnics                                                   
         hi12_132(iwk,j)=hi12_132(iwk,j)+                              
     *   dwf_132(mciesp,ik)*gi12pnt_132(j)                            
         hi12_132(j,iwk)=hi12_132(j,iwk)+                              
     *   dwf_132(mciesp,ik)*gi12pnt_132(j)                           
       enddo                                                           
            enddo                                                      
c 
c sum_i=1^{6}             
              do i=1,mcnics
        hi12(i,i)=hi12_E(i,i)+hi12_12(i,i)+              
     *  hi12_23(i,i)+hi12_13(i,i)+                           
     *  hi12_123(i,i)+hi12_132(i,i)                          
              enddo   
c sum_i=1^{6} off-diagonal
              do i=1,mcnics
              do j=1,mcnics                                          
              hi12(i,j)=hi12_E(i,j)+hi12_12(i,j)+              
     *  hi12_23(i,j)+hi12_13(i,j)+                               
     *  hi12_123(i,j)+hi12_132(i,j)                              
              enddo
              enddo
          endif                                                         
c        endif  
c     end of loop over number of shepard points                         
c                                                                       
 1000 continue 
c              
      return                                                            
      end
c***********************************************************************
c     mcv12isold
c***********************************************************************
c
      subroutine mcv12isold(e12,gi12,hi12,itypec)
c
c     This subroutine is a modified version of mcv12i subroutine.
c     It returns symmetrized V12, its gradient and Hessian.
c     The formalism is described in 'Tishchenko & Truhlar, JCTC 2007, 3, 938-948'.    
c     The current version only supports systems with n = 3 identical nuclei.
c     (O.T. November 2006; modifications June 2007)
c
      implicit double precision (a-h, o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      dimension dqs(mcmics,mcmesp+2)
      dimension dqs_12(mcmics,mcmesp+2)
      dimension dqs_23(mcmics,mcmesp+2)
      dimension dqs_13(mcmics,mcmesp+2)
      dimension dqs_123(mcmics,mcmesp+2)
      dimension dqs_132(mcmics,mcmesp+2)
      dimension w_p12(mcmesp*6+12)
      dimension w(mcmesp+2)
      dimension we11(mcmesp)                                          
      dimension we11_12(mcmesp)                                       
      dimension we11_23(mcmesp)                                       
      dimension we11_13(mcmesp)                                       
      dimension we11_123(mcmesp)                                      
      dimension we11_132(mcmesp)                                      
c      dimension F(mcmesp)
c      dimension F_12(mcmesp)
c      dimension F_23(mcmesp)
c      dimension F_13(mcmesp)
c      dimension F_123(mcmesp)
c      dimension F_132(mcmesp)
c      dimension cat(mcmesp)
c      dimension cat_12(mcmesp)
c      dimension cat_13(mcmesp)
c      dimension cat_23(mcmesp)
c      dimension cat_123(mcmesp)
c      dimension cat_132(mcmesp)
       dimension uterm(mcmesp)
       dimension uterm_12(mcmesp)
       dimension uterm_13(mcmesp)
       dimension uterm_23(mcmesp)
       dimension uterm_123(mcmesp)
       dimension uterm_132(mcmesp)
c
c      dimension dw11(mcmesp)
c      dimension dw11_12(mcmesp)                                      
c      dimension dw11_23(mcmesp)                                      
c      dimension dw11_13(mcmesp)                                      
c      dimension dw11_123(mcmesp)                                     
c      dimension dw11_132(mcmesp)                                     
c
      dimension indexw(mcmesp,6)
c      dimension w_12(mcmesp+2),dw_12(mcmesp+2)                       
c      dimension ddw1(mcmesp+2),ddw2(mcmesp+2)                        
c      dimension ddw1_E(mcmesp),ddw2_E(mcmesp)                        
c      dimension ddw1_12(mcmesp),ddw2_12(mcmesp)                      
c      dimension ddw1_23(mcmesp),ddw2_23(mcmesp)                      
c      dimension ddw1_13(mcmesp),ddw2_13(mcmesp)                      
c      dimension ddw1_123(mcmesp),ddw2_123(mcmesp)                    
c      dimension ddw1_132(mcmesp),ddw2_132(mcmesp)                    
c      dimension ddw1_p12(mcmesp*2+4),ddw2_p12(mcmesp*2+4)            
c      dimension sdw(mcmics),sddw1(mcmics,mcmics)
c      dimension sdw_p12(mcmics),sddw1_p12(mcmics,mcmics)            
c      dimension sdw_12(mcmics),sddw1_12(mcmics,mcmics)              
c      dimension sdw_23(mcmics),sddw1_23(mcmics,mcmics)              
c      dimension sdw_13(mcmics),sddw1_13(mcmics,mcmics)              
c      dimension sdw_123(mcmics),sddw1_123(mcmics,mcmics)            
c      dimension sdw_132(mcmics),sddw1_132(mcmics,mcmics)            
c
      dimension e12pnt(mcmesp),e12pf(mcmesp),e12p(mcmesp)
      dimension e12pnt_12(mcmesp),e12pf_12(mcmesp),             
     *          e12p_12(mcmesp)                                   
      dimension e12pnt_23(mcmesp),e12pf_23(mcmesp),             
     *          e12p_23(mcmesp)                                   
      dimension e12pnt_13(mcmesp),e12pf_13(mcmesp),             
     *          e12p_13(mcmesp)                                   
      dimension e12pnt_123(mcmesp),e12pf_123(mcmesp),           
     *          e12p_123(mcmesp)                                  
      dimension e12pnt_132(mcmesp),e12pf_132(mcmesp),           
     *          e12p_132(mcmesp)                                  
      dimension gi12pnt(mcmics),gi12(mcmics),hi12(mcmics,mcmics)
      dimension gi12_E(mcmics),hi12_E(mcmics,mcmics)               
      dimension gi12pnt_12(mcmics),gi12_12(mcmics),                
     * hi12_12(mcmics,mcmics)                                      
      dimension gi12pnt_23(mcmics),gi12_23(mcmics),                
     * hi12_23(mcmics,mcmics)                                      
      dimension gi12pnt_13(mcmics),gi12_13(mcmics),                
     * hi12_13(mcmics,mcmics)                                      
      dimension gi12pnt_123(mcmics),gi12_123(mcmics),              
     * hi12_123(mcmics,mcmics)                                     
      dimension gi12pnt_132(mcmics),gi12_132(mcmics),              
     * hi12_132(mcmics,mcmics)                                     
      dimension wrk(mcmics),wrk1(mcmics)
      dimension wrk_12(mcmics),wrk1_12(mcmics)                          
      dimension wrk_23(mcmics),wrk1_23(mcmics)                          
      dimension wrk_13(mcmics),wrk1_13(mcmics)                          
      dimension wrk_123(mcmics),wrk1_123(mcmics)                        
      dimension wrk_132(mcmics),wrk1_132(mcmics)                        
c      dimension dwf(mcmics)
      dimension  dwf(mcmesp*6+12,mcmicd)
      dimension  dwf_12(mcmesp+2,mcmicd)
      dimension  dwf_E(mcmesp+2,mcmicd)
      dimension  dwf_23(mcmesp+2,mcmicd)
      dimension  dwf_13(mcmesp+2,mcmicd)
      dimension  dwf_123(mcmesp+2,mcmicd)
      dimension  dwf_132(mcmesp+2,mcmicd)
      dimension  d2wf(mcmicd,mcmicd,mcmesp*6+12)
      dimension  d2wf_E(mcmicd,mcmicd,mcmesp+2)
      dimension  d2wf_12(mcmicd,mcmicd,mcmesp+2)
      dimension  d2wf_23(mcmicd,mcmicd,mcmesp+2)
      dimension  d2wf_13(mcmicd,mcmicd,mcmesp+2)
      dimension  d2wf_123(mcmicd,mcmicd,mcmesp+2)
      dimension  d2wf_132(mcmicd,mcmicd,mcmesp+2)
c
      zero = 0.d0
c 
c     zero out Shepard variables
c
c      do i=1,mcmics
c        do j=1,mcmesp+2
       do j=1,mcmesp+2
         do i=1,mcmics
          dqs(i,j) =  0.d0
          dqs_12(i,j) =  0.d0
          dqs_23(i,j) =  0.d0
          dqs_13(i,j) =  0.d0
          dqs_123(i,j) =  0.d0
          dqs_132(i,j) =  0.d0
        enddo
      enddo
      do i=1,mcmesp+2
      do j=1,mcmicd
      dwf_E(i,j)=0.d0
      dwf_12(i,j)=0.d0
      dwf_23(i,j)=0.d0
      dwf_13(i,j)=0.d0
      dwf_123(i,j)=0.d0
      dwf_132(i,j)=0.d0
      enddo
      enddo
      do k=1,mcmesp+2
      do i=1,mcmicd
      do j=1,mcmicd
      d2wf_E(i,j,k)=0.d0
      d2wf_12(i,j,k)=0.d0
      d2wf_23(i,j,k)=0.d0
      d2wf_13(i,j,k)=0.d0
      d2wf_123(i,j,k)=0.d0
      d2wf_132(i,j,k)=0.d0
      enddo
      enddo
      enddo
c      do i=1,mcmesp+2
      do i=1,mcmesp
        w(i)   =  0.d0
        e12pnt(i) = 0.0d0
        e12pf(i) = 0.0d0
        e12p(i) = 0.0d0
        e12pnt_12(i) = 0.0d0                                            
        e12pf_12(i) = 0.0d0                                             
        e12p_12(i) = 0.0d0                                              
        w_p12(i)   =  0.d0                                              
        e12pnt_23(i) = 0.0d0                                            
        e12pf_23(i) = 0.0d0                                             
        e12p_23(i) = 0.0d0                                              
        e12pnt_13(i) = 0.0d0                                            
        e12pf_13(i) = 0.0d0                                             
        e12p_13(i) = 0.0d0                                              
        e12pnt_123(i) = 0.0d0                                           
        e12pf_123(i) = 0.0d0                                            
        e12p_123(i) = 0.0d0                                             
        e12pnt_132(i) = 0.0d0                                           
        e12pf_132(i) = 0.0d0                                            
        e12p_132(i) = 0.0d0                                             
          do j=1,mcmics
            dwf(i,j)  = 0.d0
          enddo
      enddo       
       do i=1,mcmesp                                                    
        we11(i)=0.0d0                                                   
        we11_12(i)=0.0d0                                                
        we11_23(i)=0.0d0                                                
        we11_13(i)=0.0d0                                                
        we11_123(i)=0.0d0                                               
        we11_132(i)=0.0d0                                               
c        F(i)=0.0d0
c        F_12(i)=0.0d0
c        F_23(i)=0.0d0
c        F_13(i)=0.0d0
c        F_123(i)=0.0d0
c        F_132(i)=0.0d0
c        cat(i)=0.0d0
c        cat_12(i)=0.0d0
c        cat_23(i)=0.0d0
c        cat_13(i)=0.0d0
c        cat_123(i)=0.0d0
c        cat_132(i)=0.0d0
        enddo     
c        do i=1,mcmesp*6
c        Fw(i)=0.d0
c        enddo
      do i = 1, mcmics
         do j = 1, mcmics
            hi12(i,j) = zero
            hi12_E(i,j) = zero
            hi12_12(i,j) = zero                                         
            hi12_23(i,j) = zero                                         
            hi12_13(i,j) = zero                                         
            hi12_123(i,j) = zero                                        
            hi12_132(i,j) = zero                                        
         end do
         gi12(i)=zero
         gi12_E(i)=zero                                                 
         gi12_12(i)=zero                                                
         gi12_23(i)=zero                                                
         gi12_13(i)=zero                                                
         gi12_123(i)=zero                                               
         gi12_132(i)=zero                                               
      end do
       do i=1,6
       do j=1,mcmesp
        indexw(i,j)=0
       enddo
       enddo
      do i=1,mcmics                                                     
        gi12pnt(i)  = 0.d0                                              
        gi12pnt_12(i)  = 0.d0                                           
        gi12pnt_23(i)  = 0.d0                                           
        gi12pnt_13(i)  = 0.d0                                           
        gi12pnt_123(i)  = 0.d0                                          
        gi12pnt_132(i)  = 0.d0                                          
      enddo
c
       e12 = zero
       e12_12 = zero                                                    
       e12_23 = zero                                                    
       e12_13 = zero                                                    
       e12_123 = zero                                                   
       e12_132 = zero                                                   
             e12a= zero                                                 
             e12b= zero                                                 
             e12c= zero                                                 
             e12d= zero                                                 
             e12e= zero                                                 
             e12f= zero                                                 
c
c     calculate the displacement in internal coordinates used for
c     generalized distances
c
       do j=1,mcnesp+2
         do i=1,mcnics
          dqs(i,j)=qs(i)-qs0(i,j)
          dqs_12(i,j)=qs(i)-qs0_12(i,j)                                 
          dqs_23(i,j)=qs(i)-qs0_23(i,j)                                 
          dqs_13(i,j)=qs(i)-qs0_13(i,j)                                 
          dqs_123(i,j)=qs(i)-qs0_123(i,j)                               
          dqs_132(i,j)=qs(i)-qs0_132(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
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas                 
               if (dqs_12(i,j).lt.-fpi) then                            
                   dqs_12(i,j) = dqs_12(i,j)+2.0d0*fpi                  
               elseif (dqs_12(i,j).gt.fpi) then                         
                   dqs_12(i,j) = dqs_12(i,j)-2.0d0*fpi                  
               endif                                                    
            enddo                                                       
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas                 
               if (dqs_23(i,j).lt.-fpi) then                            
                   dqs_23(i,j) = dqs_23(i,j)+2.0d0*fpi                  
               elseif (dqs_23(i,j).gt.fpi) then                         
                   dqs_23(i,j) = dqs_23(i,j)-2.0d0*fpi                  
               endif                                                    
            enddo                                                       
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas                 
               if (dqs_13(i,j).lt.-fpi) then                            
                   dqs_13(i,j) = dqs_13(i,j)+2.0d0*fpi                  
               elseif (dqs_13(i,j).gt.fpi) then                         
                   dqs_13(i,j) = dqs_13(i,j)-2.0d0*fpi                  
               endif                                                    
            enddo                                                       
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas                 
               if (dqs_123(i,j).lt.-fpi) then                           
                   dqs_123(i,j) = dqs_123(i,j)+2.0d0*fpi                
               elseif (dqs_123(i,j).gt.fpi) then                        
                   dqs_123(i,j) = dqs_123(i,j)-2.0d0*fpi                
               endif                                                    
            enddo                                                       
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas                 
               if (dqs_132(i,j).lt.-fpi) then                           
                   dqs_132(i,j) = dqs_132(i,j)+2.0d0*fpi                
               elseif (dqs_132(i,j).gt.fpi) then                        
                   dqs_132(i,j) = dqs_132(i,j)-2.0d0*fpi                
               endif                                                    
            enddo                                                       
         endif
      enddo
c
c get weights
c
       call mcswtsnum(w_p12,dwf,d2wf,itypec)
c
          j = 0
c
c  loop over all (m!N) Shepard points to select weights+derivatives for the ES points
c  and leave out the data for MM structures 1 and 2.                      
           k=2                                                          
c                                                                       
           do i=0,5                                                     
           do j=1,mcnesp                                                
           indexw(j,i+1)=mcnesp*i+k*i+j                                 
           enddo                                                        
           enddo                                                        
c                                                                       
          do j = 1, mcnesp                                              
          we11(j)=w_p12(indexw(j,1))                                    
          do i=1,mcnicd
          dwf_E(j,i)=dwf(indexw(j,1),i)
          do k=1,mcnicd
          d2wf_E(i,k,j)=d2wf(i,k,indexw(j,1))
          enddo
          enddo
c          dw11(j)=dw_p12(indexw(j,1))                                  
c          ddw1_E(j)=ddw1_p12(indexw(j,1))                              
c          ddw2_E(j)=ddw2_p12(indexw(j,1))                              
          enddo                                                         
          do j = 1, mcnesp                                              
          we11_12(j)=w_p12(indexw(j,2))                                 
          do i=1,mcnicd
          dwf_12(j,i)=dwf(indexw(j,2),i)
          do k=1,mcnicd
          d2wf_12(i,k,j)=d2wf(i,k,indexw(j,2))
          enddo
          enddo
c          dw11_12(j)=dw_p12(indexw(j,2))                              
c          ddw1_12(j)=ddw1_p12(indexw(j,2))                            
c          ddw2_12(j)=ddw2_p12(indexw(j,2))                            
          enddo                                                        
          do j = 1, mcnesp                                             
          we11_23(j)=w_p12(indexw(j,3))                                
          do i=1,mcnicd
          dwf_23(j,i)=dwf(indexw(j,3),i)
          do k=1,mcnicd
          d2wf_23(i,k,j)=d2wf(i,k,indexw(j,3))
          enddo
          enddo
c          dw11_23(j)=dw_p12(indexw(j,3))                              
c          ddw1_23(j)=ddw1_p12(indexw(j,3))                             
c          ddw2_23(j)=ddw2_p12(indexw(j,3))                            
          enddo                                                        
          do j = 1, mcnesp                                             
          we11_13(j)=w_p12(indexw(j,4))                                
          do i=1,mcnicd
          dwf_13(j,i)=dwf(indexw(j,4),i)
          do k=1,mcnicd
          d2wf_13(i,k,j)=d2wf(i,k,indexw(j,4))
          enddo
          enddo
c          dw11_13(j)=dw_p12(indexw(j,4))                             
c          ddw1_13(j)=ddw1_p12(indexw(j,4))                           
c          ddw2_13(j)=ddw2_p12(indexw(j,4))                           
          enddo                                                       
          do j = 1, mcnesp                                            
          we11_123(j)=w_p12(indexw(j,5))                              
          do i=1,mcnicd
          dwf_123(j,i)=dwf(indexw(j,5),i)
          do k=1,mcnicd
          d2wf_123(i,k,j)=d2wf(i,k,indexw(j,5))
          enddo
          enddo
c          dw11_123(j)=dw_p12(indexw(j,5))                             
c          ddw1_123(j)=ddw1_p12(indexw(j,5))                           
c          ddw2_123(j)=ddw2_p12(indexw(j,5))                           
          enddo                                                        
          do j = 1, mcnesp                                             
          we11_132(j)=w_p12(indexw(j,6))                               
          do i=1,mcnicd
          dwf_132(j,i)=dwf(indexw(j,6),i)
          do k=1,mcnicd
          d2wf_132(i,k,j)=d2wf(i,k,indexw(j,6))
          enddo
          enddo
c          dw11_132(j)=dw_p12(indexw(j,6))                            
c          ddw1_132(j)=ddw1_p12(indexw(j,6))                          
c          ddw2_132(j)=ddw2_p12(indexw(j,6))                          
          enddo                                                       
          do j = 1, mcnesp                                            
          enddo  
c          
       do 1000 mciesp=1,mcnesp                                                           
c
          btrm=0.d0
          ctrm=0.d0
          qtrm=0.d0
          btrm_12=0.d0                                                  
          btrm_23=0.d0                                                  
          btrm_13=0.d0                                                  
          btrm_123=0.d0                                                 
          btrm_132=0.d0                                                 
          ctrm_12=0.d0                                                  
          ctrm_23=0.d0                                                  
          ctrm_13=0.d0                                                  
          ctrm_123=0.d0                                                 
          ctrm_132=0.d0                                                 
          qtrm_12=0.d0                                                  
          be12=0.d0                                                     
          be12_12=0.d0                                                  
          be12_23=0.d0                                                  
          be12_13=0.d0                                                  
          be12_123=0.d0                                                 
          be12_132=0.d0                                                 
c
          do i=1,mcnics
            wrk(i) =0.d0
            wrk_12(i) =0.d0                                             
            wrk_23(i) =0.d0                                             
            wrk_13(i) =0.d0                                             
            wrk_123(i) =0.d0                                            
            wrk_132(i) =0.d0                                            
            btrm=btrm+bevbm(i,mciesp)*dqs(i,mciesp)                     
            btrm_12=btrm_12+bevbm_12(i,mciesp)*dqs_12(i,mciesp)          
            btrm_23=btrm_23+bevbm_23(i,mciesp)*dqs_23(i,mciesp)         
            btrm_13=btrm_13+bevbm_13(i,mciesp)*dqs_13(i,mciesp)         
            btrm_123=btrm_123+bevbm_123(i,mciesp)*dqs_123(i,mciesp)     
            btrm_132=btrm_132+bevbm_132(i,mciesp)*dqs_132(i,mciesp)     
            do j=1,mcnics
              wrk(i)=wrk(i)+dqs(j,mciesp)*cevbm(i,j,mciesp)
          wrk_12(i)=wrk_12(i)+dqs_12(j,mciesp)*cevbm_12(i,j,mciesp)     
          wrk_23(i)=wrk_23(i)+dqs_23(j,mciesp)*cevbm_23(i,j,mciesp)     
          wrk_13(i)=wrk_13(i)+dqs_13(j,mciesp)*cevbm_13(i,j,mciesp)     
          wrk_123(i)=wrk_123(i)+dqs_123(j,mciesp)*cevbm_123(i,j,mciesp) 
          wrk_132(i)=wrk_132(i)+dqs_132(j,mciesp)*cevbm_132(i,j,mciesp) 
            enddo
            ctrm=ctrm+dqs(i,mciesp)*wrk(i)
            ctrm_12=ctrm_12+dqs_12(i,mciesp)*wrk_12(i)                  
            ctrm_23=ctrm_23+dqs_23(i,mciesp)*wrk_23(i)                  
            ctrm_13=ctrm_13+dqs_13(i,mciesp)*wrk_13(i)                  
            ctrm_123=ctrm_123+dqs_123(i,mciesp)*wrk_123(i)              
            ctrm_132=ctrm_132+dqs_132(i,mciesp)*wrk_132(i)              
          enddo
c
c     Added to avoid negative values for V12**2 term, 4/14/99 by Y. Kim
c
c           delta = 0.00016d0
c           udelta = 0.0000000256d0
c           unn = 2.d0
          be12 = 1.d0+btrm+0.5d0*ctrm
          be12_12 = 1.d0+btrm_12+0.5d0*ctrm_12                            
          be12_23 = 1.d0+btrm_23+0.5d0*ctrm_23                             
          be12_13 = 1.d0+btrm_13+0.5d0*ctrm_13                             
          be12_123 = 1.d0+btrm_123+0.5d0*ctrm_123                         
          be12_132 = 1.d0+btrm_132+0.5d0*ctrm_132                         
          e12p(mciesp) = aevbm(mciesp)*be12
          e12p_12(mciesp) = aevbm(mciesp)*be12_12                       
          e12p_23(mciesp) = aevbm(mciesp)*be12_23                       
          e12p_13(mciesp) = aevbm(mciesp)*be12_13                       
          e12p_123(mciesp) = aevbm(mciesp)*be12_123                     
          e12p_132(mciesp) = aevbm(mciesp)*be12_132                     
c
          if (e12p(mciesp).gt.0.0d0) then
cc            fixf = dexp(-delta/e12p(mciesp))
cc              fixf = 1.d0/(1.d0+(delta/e12p(mciesp))**unn)
              uterm(mciesp)=udelta/e12p(mciesp)                          1206OT08
              fixf = 1.d0/(1.d0+(uterm(mciesp))**unn)                    1206OT08
          else
            fixf = 0.0d0
          endif
          if (e12p_12(mciesp).gt.0.0d0) then                            
cc            fixf_12 = dexp(-delta/e12p_12(mciesp))                      
cc              fixf_12 = 1.d0/(1.d0+(delta/e12p_12(mciesp))**unn)
              uterm_12(mciesp)=udelta/e12p_12(mciesp)                          1206OT08
              fixf_12 = 1.d0/(1.d0+(uterm_12(mciesp))**unn)                    1206OT08
          else                                                          
            fixf_12 = 0.0d0                                             
          endif                                                         
          if (e12p_23(mciesp).gt.0.0d0) then                            
cc            fixf_23 = dexp(-delta/e12p_23(mciesp))                      
cc             fixf_23 = 1.d0/(1.d0+(delta/e12p_23(mciesp))**unn)
              uterm_23(mciesp)=udelta/e12p_23(mciesp)                          1206OT08
              fixf_23 = 1.d0/(1.d0+(uterm_23(mciesp))**unn)                    1206OT08
          else                                                          
            fixf_23 = 0.0d0                                             
          endif                                                         
          if (e12p_13(mciesp).gt.0.0d0) then                            
cc            fixf_13 = dexp(-delta/e12p_13(mciesp))                      
cc            fixf_13 = 1.d0/(1.d0+(delta/e12p_13(mciesp))**unn)
              uterm_13(mciesp)=udelta/e12p_13(mciesp)                          1206OT08
              fixf_13 = 1.d0/(1.d0+(uterm_13(mciesp))**unn)                    1206OT08
          else                                                          
            fixf_13 = 0.0d0                                             
          endif                                                         
          if (e12p_123(mciesp).gt.0.0d0) then                           
cc            fixf_123 = dexp(-delta/e12p_123(mciesp))                    
cc            fixf_123 = 1.d0/(1.d0+(delta/e12p_123(mciesp))**unn)
              uterm_123(mciesp)=udelta/e12p_123(mciesp)                          1206OT08
              fixf_123 = 1.d0/(1.d0+(uterm_123(mciesp))**unn)                    1206OT08
          else                                                          
            fixf_123 = 0.0d0                                            
          endif                                                         
          if (e12p_132(mciesp).gt.0.0d0) then                           
cc            fixf_132 = dexp(-delta/e12p_132(mciesp))                    
cc           fixf_132 = 1.d0/(1.d0+(delta/e12p_132(mciesp))**unn)
              uterm_132(mciesp)=udelta/e12p_132(mciesp)                          1206OT08
              fixf_132 = 1.d0/(1.d0+(uterm_132(mciesp))**unn)                    1206OT08
          else                                                          
            fixf_132 = 0.0d0                                            
          endif                                                         
          e12pf(mciesp) = e12p(mciesp)*fixf                             
          e12pf_12(mciesp) = e12p_12(mciesp)*fixf_12                    
          e12pf_23(mciesp) = e12p_23(mciesp)*fixf_23                    
          e12pf_13(mciesp) = e12p_13(mciesp)*fixf_13                    
          e12pf_123(mciesp) = e12p_123(mciesp)*fixf_123                 
          e12pf_132(mciesp) = e12p_132(mciesp)*fixf_132                 

          e12pnt(mciesp) = dsqrt(e12pf(mciesp))                         
          e12pnt_12(mciesp) = dsqrt(e12pf_12(mciesp))                   
          e12pnt_23(mciesp) = dsqrt(e12pf_23(mciesp))                   
          e12pnt_13(mciesp) = dsqrt(e12pf_13(mciesp))                   
          e12pnt_123(mciesp) = dsqrt(e12pf_123(mciesp))                 
          e12pnt_132(mciesp) = dsqrt(e12pf_132(mciesp))                 

          write (6,*) "WW", we11(mciesp),we11_12(mciesp),
     *    we11_23(mciesp),we11_13(mciesp),we11_123(mciesp),
     *    we11_132(mciesp),mciesp
c
        e12a = e12a+we11(mciesp)*e12pnt(mciesp)        
        e12b = e12b+we11_12(mciesp)*e12pnt_12(mciesp)    
        e12c = e12c+we11_23(mciesp)*e12pnt_23(mciesp)     
        e12d = e12d+we11_13(mciesp)*e12pnt_13(mciesp)     
        e12e = e12e+we11_123(mciesp)*e12pnt_123(mciesp)     
        e12f = e12f+we11_132(mciesp)*e12pnt_132(mciesp)     
        e12 = e12a + e12b + e12c + e12d + e12e +e12f
c
c------------------end of e12------------------------------------
c
c------------------ begin calculating the first derivatives -----
c
c     first check if it is necessary (itypec >= 1)
c
c          itypec=2
          if (itypec .eq. 1) goto 1000
          do k=1,mcnics
            wrk1s = 0.d0
            wrk1s_12 = 0.d0                                             
            wrk1s_23 = 0.d0                                             
            wrk1s_13 = 0.d0                                             
            wrk1s_123 = 0.d0                                            
            wrk1s_132 = 0.d0                                            
              do k1 = 1,mcnics                                          
                wrk1s = wrk1s+cevbm(k1,k,mciesp)*dqs(k1,mciesp)
                wrk1s_12 = wrk1s_12+                                    
     *    cevbm_12(k1,k,mciesp)*dqs_12(k1,mciesp)                       
                wrk1s_23 = wrk1s_23+                                    
     *    cevbm_23(k1,k,mciesp)*dqs_23(k1,mciesp)                       
                wrk1s_13 = wrk1s_13+                                    
     *    cevbm_13(k1,k,mciesp)*dqs_13(k1,mciesp)                       
                wrk1s_123 = wrk1s_123+                                  
     *    cevbm_123(k1,k,mciesp)*dqs_123(k1,mciesp)                     
                wrk1s_132 = wrk1s_132+                                  
     *    cevbm_132(k1,k,mciesp)*dqs_132(k1,mciesp)                     
              enddo                                                     
            wrk1(k) = wrk1s                                             
            wrk1_12(k) = wrk1s_12                                       
            wrk1_23(k) = wrk1s_23                                       
            wrk1_13(k) = wrk1s_13                                       
            wrk1_123(k) = wrk1s_123                                     
            wrk1_132(k) = wrk1s_132                                     
          enddo                                                         
          do k=1,mcnics                                                 
            if (e12p(mciesp).gt.0.0) then                               
cc              gi12pnt(k)=0.5d0*(aevbm(mciesp)*(bevbm(k,mciesp)+0.5d0*   
cc     *          (wrk(k)+wrk1(k)))*fixf+delta*fixf*(bevbm(k,mciesp)+     
cc     *                 0.5d0*(wrk(k)+wrk1(k)))/be12)/e12pnt(mciesp)     
ccc                gi12pnt(k)=0.5d0*aevbm(mciesp)*((bevbm(k,mciesp)
ccc     *          +0.5d0*
ccc     *          (wrk(k)+wrk1(k)))*fixf+delta*unn*
ccc     *          (bevbm(k,mciesp)+
ccc     *          0.5d0*(wrk(k)+wrk1(k)))/e12p(mciesp)*
ccc     *          (delta/e12p(mciesp))**(unn-1)*(1+
ccc     *          (delta/e12p(mciesp))**unn)**(-2.d0))/e12pnt(mciesp)
                gi12pnt(k)=0.5d0*aevbm(mciesp)*(bevbm(k,mciesp)
     *          +0.5d0*(wrk(k)+wrk1(k)))*fixf/e12pnt(mciesp)*
     *          (1.d0+fixf*unn*(delta/e12p(mciesp))**unn)
            else                                                        
              gi12pnt(k)=0.0d0                                          
            endif
c                                                                       
            if (e12p_12(mciesp).gt.0.0) then                            
cc              gi12pnt_12(k)=0.5d0*(aevbm(mciesp)*(bevbm_12(k,mciesp)    
cc     *        +0.5d0*                                                   
cc     *        (wrk_12(k)+wrk1_12(k)))*fixf_12+delta*fixf_12*            
cc     *        (bevbm_12(k,mciesp)+                                      
cc     *       0.5d0*(wrk_12(k)+wrk1_12(k)))/be12_12)/e12pnt_12(mciesp)   
ccc                gi12pnt_12(k)=0.5d0*aevbm(mciesp)*((bevbm_12(k,mciesp)
ccc     *          +0.5d0*
ccc     *          (wrk_12(k)+wrk1_12(k)))*fixf_12+delta*unn*
ccc     *          (bevbm_12(k,mciesp)+
ccc     *          0.5d0*(wrk_12(k)+wrk1_12(k)))/e12p_12(mciesp)*
ccc     *          (delta/e12p_12(mciesp))**(unn-1)*(1+
ccc     *          (delta/e12p_12(mciesp))**unn)**(-2.d0))/e12pnt_12(mciesp)
                gi12pnt_12(k)=0.5d0*aevbm(mciesp)*(bevbm_12(k,mciesp)
     *       +0.5d0*(wrk_12(k)+wrk1_12(k)))*fixf_12/e12pnt_12(mciesp)*
     *          (1.d0+fixf_12*unn*(delta/e12p_12(mciesp))**unn)
            else                                                        
              gi12pnt_12(k)=0.0d0                                       
            endif                                                       
c                                                                       
            if (e12p_23(mciesp).gt.0.0) then                            
cc              gi12pnt_23(k)=0.5d0*(aevbm(mciesp)*(bevbm_23(k,mciesp)    
cc     *        +0.5d0*                                                   
cc     *        (wrk_23(k)+wrk1_23(k)))*fixf_23+delta*fixf_23*            
cc     *        (bevbm_23(k,mciesp)+                                      
cc     *       0.5d0*(wrk_23(k)+wrk1_23(k)))/be12_23)/e12pnt_23(mciesp)   
ccc                gi12pnt_23(k)=0.5d0*aevbm(mciesp)*((bevbm_23(k,mciesp)
ccc     *          +0.5d0*
ccc     *          (wrk_23(k)+wrk1_23(k)))*fixf_23+delta*unn*
ccc     *          (bevbm_23(k,mciesp)+
ccc     *          0.5d0*(wrk_23(k)+wrk1_23(k)))/e12p_23(mciesp)*
ccc     *          (delta/e12p_23(mciesp))**(unn-1)*(1+
ccc     *          (delta/e12p_23(mciesp))**unn)**(-2.d0))/e12pnt_23(mciesp)
                gi12pnt_23(k)=0.5d0*aevbm(mciesp)*(bevbm_23(k,mciesp)
     *       +0.5d0*(wrk_23(k)+wrk1_23(k)))*fixf_23/e12pnt_23(mciesp)*
     *          (1.d0+fixf_23*unn*(delta/e12p_23(mciesp))**unn)
            else                                                        
              gi12pnt_23(k)=0.0d0                                       
            endif                                                       
c                                                                       
            if (e12p_13(mciesp).gt.0.0) then                            
cc              gi12pnt_13(k)=0.5d0*(aevbm(mciesp)*(bevbm_13(k,mciesp)    
cc     *        +0.5d0*                                                   
cc     *        (wrk_13(k)+wrk1_13(k)))*fixf_13+delta*fixf_13*            
cc     *        (bevbm_13(k,mciesp)+                                      
cc     *       0.5d0*(wrk_13(k)+wrk1_13(k)))/be12_13)/e12pnt_13(mciesp)   
ccc                gi12pnt_13(k)=0.5d0*aevbm(mciesp)*((bevbm_13(k,mciesp)
ccc     *          +0.5d0*
ccc     *          (wrk_13(k)+wrk1_13(k)))*fixf_13+delta*unn*
ccc     *          (bevbm_13(k,mciesp)+
ccc     *          0.5d0*(wrk_13(k)+wrk1_13(k)))/e12p_13(mciesp)*
ccc     *          (delta/e12p_13(mciesp))**(unn-1)*(1+
ccc     *          (delta/e12p_13(mciesp))**unn)**(-2.d0))/e12pnt_13(mciesp)
                gi12pnt_13(k)=0.5d0*aevbm(mciesp)*(bevbm_13(k,mciesp)
     *       +0.5d0*(wrk_13(k)+wrk1_13(k)))*fixf_13/e12pnt_13(mciesp)*
     *          (1.d0+fixf_13*unn*(delta/e12p_13(mciesp))**unn)
            else                                                        
              gi12pnt_13(k)=0.0d0                                       
            endif                                                       
c                                                                       
            if (e12p_123(mciesp).gt.0.0) then                           
cc              gi12pnt_123(k)=0.5d0*(aevbm(mciesp)*(bevbm_123(k,mciesp)  
cc     *        +0.5d0*                                                   
cc     *        (wrk_123(k)+wrk1_123(k)))*fixf_123+delta*fixf_123*        
cc     *        (bevbm_123(k,mciesp)+                                     
cc     *        0.5d0*(wrk_123(k)+                                        
cc     *        wrk1_123(k)))/be12_123)/e12pnt_123(mciesp)                
ccc                gi12pnt_123(k)=0.5d0*aevbm(mciesp)*((bevbm_123(k,mciesp)
ccc     *          +0.5d0*
ccc     *          (wrk_123(k)+wrk1_123(k)))*fixf_123+delta*unn*
ccc     *          (bevbm_123(k,mciesp)+
ccc     *          0.5d0*(wrk_123(k)+wrk1_123(k)))/e12p_123(mciesp)*
ccc     *          (delta/e12p_123(mciesp))**(unn-1)*(1+
ccc     *          (delta/e12p_123(mciesp))**unn)**(-2.d0))/
ccc     *          e12pnt_123(mciesp)
                gi12pnt_123(k)=
     *          0.5d0*aevbm(mciesp)*(bevbm_123(k,mciesp)
     *          +0.5d0*(wrk_123(k)+
     *          wrk1_123(k)))*fixf_123/e12pnt_123(mciesp)*
     *          (1.d0+fixf_123*unn*(delta/e12p_123(mciesp))**unn)
            else                                                        
              gi12pnt_123(k)=0.0d0                                      
            endif                                                       
c                                                                       
            if (e12p_132(mciesp).gt.0.0) then                           
cc              gi12pnt_132(k)=0.5d0*(aevbm(mciesp)*(bevbm_132(k,mciesp)  
cc     *        +0.5d0*                                                   
cc     *        (wrk_132(k)+wrk1_132(k)))*fixf_132+delta*fixf_132*        
cc     *        (bevbm_132(k,mciesp)+                                     
cc     *        0.5d0*(wrk_132(k)+                                        
cc     *        wrk1_132(k)))/be12_132)/e12pnt_132(mciesp)                
ccc                gi12pnt_132(k)=0.5d0*aevbm(mciesp)*((bevbm_132(k,mciesp)
ccc     *          +0.5d0*
ccc     *          (wrk_132(k)+wrk1_132(k)))*fixf_132+delta*unn*
ccc     *          (bevbm_132(k,mciesp)+
ccc     *          0.5d0*(wrk_132(k)+wrk1_132(k)))/e12p_132(mciesp)*
ccc     *          (delta/e12p_132(mciesp))**(unn-1)*(1+
ccc     *          (delta/e12p_132(mciesp))**unn)**(-2.d0))/
ccc     *          e12pnt_132(mciesp)
                gi12pnt_132(k)=
     *          0.5d0*aevbm(mciesp)*(bevbm_132(k,mciesp)
     *          +0.5d0*(wrk_132(k)+
     *          wrk1_132(k)))*fixf_132/e12pnt_132(mciesp)*
     *          (1.d0+fixf_132*unn*(delta/e12p_132(mciesp))**unn)
            else                                                        
              gi12pnt_132(k)=0.0d0                                      
            endif                                                       
c                                                                       
          enddo
c                                                                       
c     weight the gradient                                               
c                                                                       
          do k=1,mcnics                                                 
            gi12_E(k) = gi12_E(k) + gi12pnt(k)*we11(mciesp)
            gi12_12(k) = gi12_12(k) +                                  
     *     gi12pnt_12(k)*we11_12(mciesp)
           gi12_23(k) = gi12_23(k) +                                   
     *     gi12pnt_23(k)*we11_23(mciesp)
           gi12_13(k) = gi12_13(k) +                                   
     *     gi12pnt_13(k)*we11_13(mciesp)
           gi12_123(k) = gi12_123(k) +                                 
     *     gi12pnt_123(k)*we11_123(mciesp)
           gi12_132(k) = gi12_132(k) +                                 
     *     gi12pnt_132(k)*we11_132(mciesp)
c           write (*,*) "gi12",gi12_E(k),gi12_12(k),gi12_23(k),
c     *     gi12_13(k),gi12_123(k),gi12_132(k),k
c           write (*,*) "gi12",gi12_13(k),gi12pnt_13(k),we11_13(mciesp)
c            write (*,*) "gi12pnt(k)",gi12pnt(k),gi12pnt_12(k),
c     *    gi12pnt_23(k),gi12pnt_13(k),gi12pnt_123(k),gi12pnt_132(k),k
          enddo
c            do k=1,mcnics
c         gi12(k)=gi12_E(k)+gi12_12(k)+gi12_23(k)+
c     &   gi12_13(k)+gi12_123(k)+gi12_132(k)  
c            enddo
c 
c     if shepard interpolation is used, calculate dwf(k)=dW(i)/dqs(k)
c
        if (mcimre.eq.2) then
        do k=1,mcnicb
              kw=mciicb(k)
        gi12_E(kw)=gi12_E(kw)+e12pnt(mciesp)*dwf_E(mciesp,kw)
c
        gi12_12(kw)=gi12_12(kw)+e12pnt_12(mciesp)*dwf_12(mciesp,kw)            
c              
        gi12_23(kw)=gi12_23(kw)+e12pnt_23(mciesp)*dwf_23(mciesp,kw)           
c               
        gi12_13(kw)=gi12_13(kw)+e12pnt_13(mciesp)*dwf_13(mciesp,kw)          
c               
        gi12_123(kw)=gi12_123(kw)+
     &   e12pnt_123(mciesp)*dwf_123(mciesp,kw)   
c               
        gi12_132(kw)=gi12_132(kw)+
     &   e12pnt_132(mciesp)*dwf_132(mciesp,kw)
c              
        enddo
        do k=1,mcnics
         gi12(k)=gi12_E(k)+gi12_12(k)+gi12_23(k)+
     &   gi12_13(k)+gi12_123(k)+gi12_132(k)  
        enddo
        endif
c
c----------------- end of first derivative calculations ------
c
c------------------ begin calculating the hessian -----
c
c     first check if it is necessary (itypec = 1)
c
          if (itypec .eq. 2) goto 1000
c
c   1. calculate dd(e12(i))/(dqs(k)dqs(s))*w(i)
c
          if (e12p(mciesp).gt.0.0) then
            do ik=1,mcnics
              do is=ik,mcnics
c                hi12_E(is,ik)=hi12_E(is,ik)+(-gi12pnt(is)*gi12pnt(ik)+
c     *           0.5d0*(aevbm(mciesp)*fixf*0.5d0*(cevbm(is,ik,mciesp)+
c     *                  cevbm(ik,is,mciesp))+delta*delta*fixf*
c     *                (bevbm(is,mciesp)+0.5d0*(wrk(is)+wrk1(is)))*
c     *                 (bevbm(ik,mciesp)+0.5d0*(wrk(ik)+wrk1(ik)))/    
c     *            (aevbm(mciesp)*be12**3)+0.5d0*(cevbm(is,ik,mciesp)+
c     *                   cevbm(ik,is,mciesp))*delta*fixf/be12))
c     *                    /e12pnt(mciesp)*we11(mciesp)
c
               hi12_E(is,ik)=hi12_E(is,ik)+(-gi12pnt(is)*gi12pnt(ik)+         0612OT08
     *          aevbm(mciesp)*aevbm(mciesp)*unn*unn*fixf*fixf*                   0612OT08
     *          (bevbm(is,mciesp)+0.5d0*(wrk(is)+wrk1(is)))*                   0612OT08
     *          (bevbm(ik,mciesp)+                                             0612OT08
     *          0.5d0*(wrk(ik)+wrk1(ik)))/e12p(mciesp)*                        0612OT08
     *      uterm(mciesp)**unn*(unn*fixf*uterm(mciesp)**unn-unn+1.d0)+         0612OT08
     *          0.5d0*aevbm(mciesp)*0.5d0*(cevbm(is,ik,mciesp)+                0612OT08
     *        cevbm(ik,is,mciesp))*fixf*(unn*fixf*uterm(mciesp)**unn+          0612OT08
     *          1.d0))/e12pnt(mciesp)*we11(mciesp)                             0612OT08
                hi12_E(ik,is)=hi12_E(is,ik)              
              enddo
            enddo
          endif
c
          if (e12p_12(mciesp).gt.0.0) then                              
            do ik=1,mcnics                                              
              do is=ik,mcnics                                           
c         hi12_12(is,ik)=hi12_12(is,ik)+
c     *   (-gi12pnt_12(is)*gi12pnt_12(ik)+
c     *   0.5d0*(aevbm(mciesp)*fixf_12*0.5d0*(cevbm_12(is,ik,mciesp)+    
c     *   cevbm_12(ik,is,mciesp))+delta*delta*fixf_12*                   
c     *   (bevbm_12(is,mciesp)+0.5d0*(wrk_12(is)+wrk1_12(is)))*          
c     *   (bevbm_12(ik,mciesp)+0.5d0*(wrk_12(ik)+wrk1_12(ik)))/          
c     *   (aevbm(mciesp)*be12_12**3)+0.5d0*(cevbm_12(is,ik,mciesp)+      
c     *   cevbm_12(ik,is,mciesp))*delta*fixf_12/be12_12))                
c     *   /e12pnt_12(mciesp)*we11_12(mciesp)
          hi12_12(is,ik)=hi12_12(is,ik)+
     *    (-gi12pnt_12(is)*gi12pnt_12(ik)+                                        0612OT08
     *    aevbm(mciesp)*aevbm(mciesp)*unn*unn*fixf_12*fixf_12*                      0612OT08
     *    (bevbm_12(is,mciesp)+0.5d0*(wrk_12(is)+wrk1_12(is)))*                   0612OT08
     *    (bevbm_12(ik,mciesp)+                                                   0612OT08
     *    0.5d0*(wrk_12(ik)+wrk1_12(ik)))/e12p_12(mciesp)*                        0612OT08
     *    uterm_12(mciesp)**unn*(unn*fixf_12*uterm_12(mciesp)**unn-unn                0612OT08
     *    +1.d0)+                                                                 0612OT08
     *    0.5d0*aevbm(mciesp)*0.5d0*(cevbm_12(is,ik,mciesp)+                      0612OT08
     *    cevbm_12(ik,is,mciesp))*                                                0612OT08
     *    fixf_12*(unn*fixf_12*uterm_12(mciesp)**unn+                               0612OT08
     *    1.d0))/e12pnt_12(mciesp)*we11_12(mciesp)                                0612OT08
          hi12_12(ik,is)=hi12_12(is,ik)                                           
              enddo                                                     
            enddo                                                       
          endif                                                         
c                                                                       
          if (e12p_23(mciesp).gt.0.0) then                              
            do ik=1,mcnics                                              
              do is=ik,mcnics                                           
c          hi12_23(is,ik)=hi12_23(is,ik)+
c     *    (-gi12pnt_23(is)*gi12pnt_23(ik)+
c     *    0.5d0*(aevbm(mciesp)*fixf_23*0.5d0*(cevbm_23(is,ik,mciesp)+   
c     *    cevbm_23(ik,is,mciesp))+delta*delta*fixf_23*                  
c     *    (bevbm_23(is,mciesp)+0.5d0*(wrk_23(is)+wrk1_23(is)))*         
c     *    (bevbm_23(ik,mciesp)+0.5d0*(wrk_23(ik)+wrk1_23(ik)))/         
c     *    (aevbm(mciesp)*be12_23**3)+0.5d0*(cevbm_23(is,ik,mciesp)+     
c     *    cevbm_23(ik,is,mciesp))*delta*fixf_23/be12_23))               
c     *    /e12pnt_23(mciesp)*we11_23(mciesp)
          hi12_23(is,ik)=hi12_23(is,ik)+
     *    (-gi12pnt_23(is)*gi12pnt_23(ik)+                                        0612OT08
     *    aevbm(mciesp)*aevbm(mciesp)*unn*unn*fixf_23*fixf_23*                      0612OT08
     *    (bevbm_23(is,mciesp)+0.5d0*(wrk_23(is)+wrk1_23(is)))*                   0612OT08
     *    (bevbm_23(ik,mciesp)+                                                   0612OT08
     *    0.5d0*(wrk_23(ik)+wrk1_23(ik)))/e12p_23(mciesp)*                        0612OT08
     *    uterm_23(mciesp)**unn*(unn*fixf_23*uterm_23(mciesp)**unn-unn                0612OT08
     *    +1.d0)+                                                                 0612OT08
     *    0.5d0*aevbm(mciesp)*0.5d0*(cevbm_23(is,ik,mciesp)+                      0612OT08
     *    cevbm_23(ik,is,mciesp))*                                                0612OT08
     *    fixf_23*(unn*fixf_23*uterm_23(mciesp)**unn+                               0612OT08
     *    1.d0))/e12pnt_23(mciesp)*we11_23(mciesp)                                0612OT08
                hi12_23(ik,is)=hi12_23(is,ik)                                     
              enddo                                                     
            enddo                                                       
          endif                                                         
c                                                                       
          if (e12p_13(mciesp).gt.0.0) then                              
            do ik=1,mcnics                                              
              do is=ik,mcnics                                           
c          hi12_13(is,ik)=hi12_13(is,ik)+
c     *    (-gi12pnt_13(is)*gi12pnt_13(ik)+
c     *    0.5d0*(aevbm(mciesp)*fixf_13*0.5d0*(cevbm_13(is,ik,mciesp)+   
c     *    cevbm_13(ik,is,mciesp))+delta*delta*fixf_13*                  
c     *    (bevbm_13(is,mciesp)+0.5d0*(wrk_13(is)+wrk1_13(is)))*         
c     *    (bevbm_13(ik,mciesp)+0.5d0*(wrk_13(ik)+wrk1_13(ik)))/         
c     *    (aevbm(mciesp)*be12_13**3)+0.5d0*(cevbm_13(is,ik,mciesp)+     
c     *    cevbm_13(ik,is,mciesp))*delta*fixf_13/be12_13))               
c     *    /e12pnt_13(mciesp)*we11_13(mciesp)
          hi12_13(is,ik)=hi12_13(is,ik)+
     *    (-gi12pnt_13(is)*gi12pnt_13(ik)+                                        0612OT08
     *    aevbm(mciesp)*aevbm(mciesp)*unn*unn*fixf_13*fixf_13*                      0612OT08
     *    (bevbm_13(is,mciesp)+0.5d0*(wrk_13(is)+wrk1_13(is)))*                   0612OT08
     *    (bevbm_13(ik,mciesp)+                                                   0612OT08
     *    0.5d0*(wrk_13(ik)+wrk1_13(ik)))/e12p_13(mciesp)*                        0612OT08
     *    uterm_13(mciesp)**unn*(unn*fixf_13*uterm_13(mciesp)**unn-unn                0612OT08
     *    +1.d0)+                                                                 0612OT08
     *    0.5d0*aevbm(mciesp)*0.5d0*(cevbm_13(is,ik,mciesp)+                      0612OT08
     *    cevbm_13(ik,is,mciesp))*                                                0612OT08
     *    fixf_13*(unn*fixf_13*uterm_13(mciesp)**unn+                               0612OT08
     *    1.d0))/e12pnt_13(mciesp)*we11_13(mciesp)                                0612OT08
                hi12_13(ik,is)=hi12_13(is,ik)                                     
              enddo                                                     
            enddo                                                       
          endif                                                         
c                                                                       
          if (e12p_123(mciesp).gt.0.0) then                             
            do ik=1,mcnics                                              
              do is=ik,mcnics                                           
c        hi12_123(is,ik)=hi12_123(is,ik)+(-gi12pnt_123(is)*              
c     *  gi12pnt_123(ik)+                                                
c     *  0.5d0*(aevbm(mciesp)*fixf_123*0.5d0*(cevbm_123(is,ik,mciesp)+   
c     *  cevbm_123(ik,is,mciesp))+delta*delta*fixf_123*                  
c     *  (bevbm_123(is,mciesp)+0.5d0*(wrk_123(is)+wrk1_123(is)))*        
c     *  (bevbm_123(ik,mciesp)+0.5d0*(wrk_123(ik)+wrk1_123(ik)))/        
c     *  (aevbm(mciesp)*be12_123**3)+0.5d0*(cevbm_123(is,ik,mciesp)+     
c     *  cevbm_123(ik,is,mciesp))*delta*fixf_123/be12_123))              
c     *  /e12pnt_123(mciesp)*we11_123(mciesp)
          hi12_123(is,ik)=hi12_123(is,ik)+
     *    (-gi12pnt_123(is)*gi12pnt_123(ik)+                                       0612OT08
     *    aevbm(mciesp)*aevbm(mciesp)*unn*unn*fixf_123*fixf_123*                     0612OT08
     *    (bevbm_123(is,mciesp)+0.5d0*(wrk_123(is)+wrk1_123(is)))*                 0612OT08
     *    (bevbm_123(ik,mciesp)+                                                   0612OT08
     *    0.5d0*(wrk_123(ik)+wrk1_123(ik)))/e12p_123(mciesp)*                      0612OT08
     * uterm_123(mciesp)**unn*(unn*fixf_123*uterm_123(mciesp)**unn-unn              0612OT08
     *    +1.d0)+                                                                  0612OT08
     *    0.5d0*aevbm(mciesp)*0.5d0*(cevbm_123(is,ik,mciesp)+                      0612OT08
     *    cevbm_123(ik,is,mciesp))*                                                0612OT08
     *    fixf_123*(unn*fixf_123*uterm_123(mciesp)**unn+                             0612OT08
     *    1.d0))/e12pnt_123(mciesp)*we11_123(mciesp)                               0612OT08
                hi12_123(ik,is)=hi12_123(is,ik)                         
              enddo                                                     
            enddo                                                       
          endif                                                         
c                                                                       
          if (e12p_132(mciesp).gt.0.0) then                             
            do ik=1,mcnics                                              
              do is=ik,mcnics                                           
c         hi12_132(is,ik)=hi12_132(is,ik)+(-gi12pnt_132(is)*             
c     *   gi12pnt_132(ik)+                                               
c     *   0.5d0*(aevbm(mciesp)*fixf_132*0.5d0*(cevbm_132(is,ik,mciesp)+  
c     *   cevbm_132(ik,is,mciesp))+delta*delta*fixf_132*                 
c     *   (bevbm_132(is,mciesp)+0.5d0*(wrk_132(is)+wrk1_132(is)))*       
c     *   (bevbm_132(ik,mciesp)+0.5d0*(wrk_132(ik)+wrk1_132(ik)))/       
c     *   (aevbm(mciesp)*be12_132**3)+0.5d0*(cevbm_132(is,ik,mciesp)+    
c     *   cevbm_132(ik,is,mciesp))*delta*fixf_132/be12_132))             
c     *   /e12pnt_132(mciesp)*we11_132(mciesp)
          hi12_132(is,ik)=hi12_132(is,ik)+
     *    (-gi12pnt_132(is)*gi12pnt_132(ik)+
     *    aevbm(mciesp)*aevbm(mciesp)*unn*unn*fixf_132*fixf_132*                      0612OT08
     *    (bevbm_132(is,mciesp)+0.5d0*(wrk_132(is)+wrk1_132(is)))*                  0612OT08
     *    (bevbm_132(ik,mciesp)+                                                    0612OT08
     *    0.5d0*(wrk_132(ik)+wrk1_132(ik)))/e12p_132(mciesp)*                       0612OT08
     * uterm_132(mciesp)**unn*(unn*fixf_132*uterm_132(mciesp)**unn-unn               0612OT08
     *    +1.d0)+                                                                   0612OT08
     *    0.5d0*aevbm(mciesp)*0.5d0*(cevbm_132(is,ik,mciesp)+                       0612OT08
     *    cevbm_132(ik,is,mciesp))*                                                 0612OT08
     *    fixf_132*(unn*fixf_132*uterm_132(mciesp)**unn+                              0612OT08
     *    1.d0))/e12pnt_132(mciesp)*we11_132(mciesp)                                0612OT08
                hi12_132(ik,is)=hi12_132(is,ik)                                    
              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                      
          if (mcimre.eq.2) then                                         
c            ddwf2_E = ddw2_E(mciesp)/wsum_p12-                              
c     *   we11(mciesp)*sddw2/(wsum_p12*wsum_p12)                         
            do ik=1,mcnicb                                              
              iwk=mciicb(ik)                                            
c              detqk=dqs(iwk,mciesp)                                     
              do is=ik,mcnicb                                           
                iws=mciicb(is)                                          
c                detqs=dqs(iws,mciesp)                                   
c                d2wf_E=(ddw1_E(mciesp)*detqk*detqs*wsum_p12               
c     *              -dw11(mciesp)*detqk*sdw(is)                         
c     *              -we11(mciesp)*sddw1(is,ik)                          
c     *              -dw11(mciesp)*detqs*sdw(ik)                           
c     *              +2.d0*we11(mciesp)*sdw(ik)*
c     *               sdw(is)/wsum_p12)/(wsum_p12**2)  
c                if(iws .eq. iwk)d2wf_E=d2wf_E+ddwf2_E                         
                hi12_E(iws,iwk)=hi12_E(iws,iwk)+
     *          d2wf_E(iws,iwk,mciesp)*e12pnt(mciesp)         
                hi12_E(iwk,iws)=hi12_E(iws,iwk)                             
              enddo        
c                                                                       
c   3. calculate cross terms                                            
c                                                                       
              do j=1,mcnics                                             
c                hi12_E(iwk,j)=hi12_E(iwk,j)+dwf(ik)*gi12pnt(j)              
c                hi12_E(j,iwk)=hi12_E(j,iwk)+dwf(ik)*gi12pnt(j)              
                hi12_E(iwk,j)=hi12_E(iwk,j)+
     *          dwf_E(mciesp,iwk)*gi12pnt(j)
                hi12_E(j,iwk)=hi12_E(j,iwk)+
     *          dwf_E(mciesp,iwk)*gi12pnt(j)
              enddo                                                     
             enddo                                                      
c                                                                       
c            ddwf2_12 = ddw2_12(mciesp)/wsum_p12-                      
c     *  we11_12(mciesp)*sddw2_12/(wsum_p12*wsum_p12)                  
            do ik=1,mcnicb                                             
              iwk=mciicb(ik)                                           
              detqk_12=dqs_12(iwk,mciesp)                              
              do is=ik,mcnicb                                          
                iws=mciicb(is)                                         
                detqs_12=dqs_12(iws,mciesp)                            
c        d2wf_12=(ddw1_12(mciesp)*detqk_12*detqs_12*wsum_p12           
c     *  -dw11_12(mciesp)*detqk_12*sdw_12(is)                          
c     *  -we11_12(mciesp)*sddw1_12(is,ik)                              
c     *  -dw11_12(mciesp)*detqs_12*sdw_12(ik)                          
c     *  +2.d0*we11_12(mciesp)*sdw_12(ik)*                             
c     *  sdw_12(is)/wsum_p12)/(wsum_p12**2)                            
c        if(iws .eq. iwk)d2wf_12=d2wf_12+ddwf2_12                      
        hi12_12(iws,iwk)=hi12_12(iws,iwk)+
     *  d2wf_12(iws,iwk,mciesp)*e12pnt_12(mciesp)  
        hi12_12(iwk,iws)=hi12_12(iws,iwk)                              
              enddo                                                    
c                                                                      
c   3. calculate cross terms                                           
c                                                                      
       do j=1,mcnics                                                   
c         hi12_12(iwk,j)=hi12_12(iwk,j)+dwf_12(ik)*gi12pnt_12(j)       
c         hi12_12(j,iwk)=hi12_12(j,iwk)+dwf_12(ik)*gi12pnt_12(j)       
         hi12_12(iwk,j)=hi12_12(iwk,j)+
     *   dwf_12(mciesp,iwk)*gi12pnt_12(j)   
         hi12_12(j,iwk)=hi12_12(j,iwk)+
     *   dwf_12(mciesp,iwk)*gi12pnt_12(j)  
       enddo                                                           
            enddo                                                      
c                                                                      
c            ddwf2_23= ddw2_23(mciesp)/wsum_p12-                       
c     *  we11_23(mciesp)*sddw2_23/(wsum_p12*wsum_p12)                  
            do ik=1,mcnicb                                             
              iwk=mciicb(ik)                                           
              detqk_23=dqs_23(iwk,mciesp)                              
              do is=ik,mcnicb                                          
                iws=mciicb(is)                                         
                detqs_23=dqs_23(iws,mciesp)                            
c        d2wf_23=(ddw1_23(mciesp)*detqk_23*detqs_23*wsum_p12           
c     *  -dw11_23(mciesp)*detqk_23*sdw_23(is)                          
c     *  -we11_23(mciesp)*sddw1_23(is,ik)                              
c     *  -dw11_23(mciesp)*detqs_23*sdw_23(ik)                          
c     *  +2.d0*we11_23(mciesp)*sdw_23(ik)*                             
c     *  sdw_23(is)/wsum_p12)/(wsum_p12**2)                            
c        if(iws .eq. iwk)d2wf_23=d2wf_23+ddwf2_23                      
        hi12_23(iws,iwk)=hi12_23(iws,iwk)+
     *  d2wf_23(iws,iwk,mciesp)*e12pnt_23(mciesp)  
        hi12_23(iwk,iws)=hi12_23(iws,iwk)                         
              enddo                                                    
c                                                                      
c   3. calculate cross terms                                           
c                                                                      
       do j=1,mcnics                                                   
c         hi12_23(iwk,j)=hi12_23(iwk,j)+dwf_23(ik)*gi12pnt_23(j)       
c         hi12_23(j,iwk)=hi12_23(j,iwk)+dwf_23(ik)*gi12pnt_23(j)       
         hi12_23(iwk,j)=hi12_23(iwk,j)+
     *   dwf_23(mciesp,iwk)*gi12pnt_23(j) 
         hi12_23(j,iwk)=hi12_23(j,iwk)+
     *   dwf_23(mciesp,iwk)*gi12pnt_23(j)
       enddo                                                          
            enddo                                                     
c                                                                     
c            ddwf2_13 = ddw2_13(mciesp)/wsum_p12-                     
c     *  we11_13(mciesp)*sddw2_13/(wsum_p12*wsum_p12)                 
            do ik=1,mcnicb                                            
              iwk=mciicb(ik)                                          
              detqk_13=dqs_13(iwk,mciesp)                             
              do is=ik,mcnicb                                         
                iws=mciicb(is)                                        
                detqs_13=dqs_13(iws,mciesp)                           
c        d2wf_13=(ddw1_13(mciesp)*detqk_13*detqs_13*wsum_p12          
c     *  -dw11_13(mciesp)*detqk_13*sdw_13(is)                         
c     *  -we11_13(mciesp)*sddw1_13(is,ik)                             
c     *  -dw11_13(mciesp)*detqs_13*sdw_13(ik)                         
c     *  +2.d0*we11_13(mciesp)*sdw_13(ik)*                            
c     *  sdw_13(is)/wsum_p12)/(wsum_p12**2)                           
c        if(iws .eq. iwk)d2wf_13=d2wf_13+ddwf2_13                     
        hi12_13(iws,iwk)=hi12_13(iws,iwk)+
     *  d2wf_13(iws,iwk,mciesp)*e12pnt_13(mciesp)  
        hi12_13(iwk,iws)=hi12_13(iws,iwk)                            
              enddo                                                   
c                                                                     
c   3. calculate cross terms                                          
c                                                                     
       do j=1,mcnics                                                  
c         hi12_13(iwk,j)=hi12_13(iwk,j)+dwf_13(ik)*gi12pnt_13(j)        
c         hi12_13(j,iwk)=hi12_13(j,iwk)+dwf_13(ik)*gi12pnt_13(j)        
         hi12_13(iwk,j)=hi12_13(iwk,j)+
     *   dwf_13(mciesp,iwk)*gi12pnt_13(j)   
         hi12_13(j,iwk)=hi12_13(j,iwk)+
     *   dwf_13(mciesp,iwk)*gi12pnt_13(j)  
       enddo                                                            
            enddo                                                       
c                                                                       
c            ddwf2_123 = ddw2_123(mciesp)/wsum_p12-                     
c     *  we11_123(mciesp)*sddw2_123/(wsum_p12*wsum_p12)                 
            do ik=1,mcnicb                                              
              iwk=mciicb(ik)                                            
              detqk_123=dqs_123(iwk,mciesp)                             
              do is=ik,mcnicb                                           
                iws=mciicb(is)                                          
                detqs_123=dqs_123(iws,mciesp)                           
c        d2wf_123=(ddw1_123(mciesp)*detqk_123*detqs_123*wsum_p12        
c     *  -dw11_123(mciesp)*detqk_123*sdw_123(is)                        
c     *  -we11_123(mciesp)*sddw1_123(is,ik)                             
c     *  -dw11_123(mciesp)*detqs_123*sdw_123(ik)                        
c     *  +2.d0*we11_123(mciesp)*sdw_123(ik)*                            
c     *  sdw_123(is)/wsum_p12)/(wsum_p12**2)                            
c        if(iws .eq. iwk)d2wf_123=d2wf_123+ddwf2_123                    
        hi12_123(iws,iwk)=hi12_123(iws,iwk)+                            
     *  d2wf_123(iws,iwk,mciesp)*e12pnt_123(mciesp)                    
        hi12_123(iwk,iws)=hi12_123(iws,iwk)                             
              enddo                                                   
c                                                                     
c   3. calculate cross terms                                          
c                                                                     
       do j=1,mcnics                                                  
c         hi12_123(iwk,j)=hi12_123(iwk,j)+                            
c     *  dwf_123(ik)*gi12pnt_123(j)                                   
c         hi12_123(j,iwk)=hi12_123(j,iwk)+                            
c     *   dwf_123(ik)*gi12pnt_123(j)                                  
         hi12_123(iwk,j)=hi12_123(iwk,j)+                             
     *  dwf_123(mciesp,ik)*gi12pnt_123(j)    
         hi12_123(j,iwk)=hi12_123(j,iwk)+                             
     *   dwf_123(mciesp,ik)*gi12pnt_123(j)      
       enddo                                                          
            enddo                                                     
c                                                                     
c            ddwf2_132 = ddw2_132(mciesp)/wsum_p12-                   
c     *  we11_132(mciesp)*sddw2_132/(wsum_p12*wsum_p12)               
            do ik=1,mcnicb                                            
              iwk=mciicb(ik)                                          
              detqk_132=dqs_132(iwk,mciesp)                           
              do is=ik,mcnicb                                         
                iws=mciicb(is)                                        
                detqs_132=dqs_132(iws,mciesp)                         
c        d2wf_132=(ddw1_132(mciesp)*detqk_132*detqs_132*wsum_p12      
c     *  -dw11_132(mciesp)*detqk_132*sdw_132(is)                       
c     *  -we11_132(mciesp)*sddw1_132(is,ik)                            
c     *  -dw11_132(mciesp)*detqs_132*sdw_132(ik)                       
c     *  +2.d0*we11_132(mciesp)*sdw_132(ik)*                           
c     *  sdw_132(is)/wsum_p12)/(wsum_p12**2)                           
c        if(iws .eq. iwk)d2wf_132=d2wf_132+ddwf2_132                   
        hi12_132(iws,iwk)=hi12_132(iws,iwk)+                           
     *  d2wf_132(iws,iwk,mciesp)*e12pnt_132(mciesp)                    
        hi12_132(iwk,iws)=hi12_132(iws,iwk)                            
              enddo                                                    
c                                                                      
c   3. calculate cross terms                                           
c                                                                      
       do j=1,mcnics                                                   
c         hi12_132(iwk,j)=hi12_132(iwk,j)+                             
c     *   dwf_132(ik)*gi12pnt_132(j)                                   
c         hi12_132(j,iwk)=hi12_132(j,iwk)+                             
c     *   dwf_132(ik)*gi12pnt_132(j)                                   
         hi12_132(iwk,j)=hi12_132(iwk,j)+                              
     *   dwf_132(mciesp,ik)*gi12pnt_132(j)                            
         hi12_132(j,iwk)=hi12_132(j,iwk)+                              
     *   dwf_132(mciesp,ik)*gi12pnt_132(j)                           
       enddo                                                           
            enddo                                                      
c 
c              do ik=1,mcnicb                                          
c              iwk=mciicb(ik)                                          
c              do is=ik,mcnicb                                         
c                iws=mciicb(is)                                        
c        hi12(iws,iwk)=hi12_E(iws,iwk)+hi12_12(iws,iwk)+               
c     *  hi12_23(iws,iwk)+hi12_13(iws,iwk)+                            
c     *  hi12_123(iws,iwk)+hi12_132(iws,iwk)                           
c        hi12(iwk,iws)=hi12(iws,iwk)                                   
c              enddo                                                   
c              do j=1,mcnics                                           
c              hi12(iwk,j)=hi12_E(iwk,j)+hi12_12(iwk,j)+               
c     *  hi12_23(iwk,j)+hi12_13(iwk,j)+                                
c     *  hi12_123(iwk,j)+hi12_132(iwk,j)                               
c              enddo                                                     
c              enddo     
c sum_i=1^{6}             
              do i=1,mcnics
        hi12(i,i)=hi12_E(i,i)+hi12_12(i,i)+              
     *  hi12_23(i,i)+hi12_13(i,i)+                           
     *  hi12_123(i,i)+hi12_132(i,i)                          
              enddo   
c sum_i=1^{6} off-diagonal
              do i=1,mcnics
              do j=1,mcnics                                          
              hi12(i,j)=hi12_E(i,j)+hi12_12(i,j)+              
     *  hi12_23(i,j)+hi12_13(i,j)+                               
     *  hi12_123(i,j)+hi12_132(i,j)                              
              enddo
              enddo
          endif                                                         
c        endif  
c     end of loop over number of shepard points                         
c                                                                       
 1000 continue 
c              
      return                                                            
      end                                                               
c***********************************************************************
c     mcviic                                                            
c***********************************************************************
c                                                                       
      subroutine mcviic(xii,ex,gx,hx,itypec,iconf,iperm)                      
c                                                                       
c     This subroutine is the driver for the molecular mechanics         
c     calculations.                                                     
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
      dimension xii(mcmcar)
      dimension gx(mcmcar)
      dimension hx(mcmcar,mcmcar)
c
      character*3 atnmtn(mcmatm)
      character*80 tranky(mcmkey)
      integer itgtn(mcmatm), itptn(mcmatm), intn(mcmatm),
     *        ic12tn(mcmatm,mcmatm)
      real*8 transx(mcmcar)
      real*8 enertk
      real*8 dxtk(mcmcar)
      real*8 ftk(mcmcar,mcmcar)
c 1030HL03s
      integer tnky                                                      1201HL03
c 1030HL03e
c
c
c  Initialize the variables
c
      ex=0.d0
      do i=1,mcmcar
        gx(i)=0.d0
      enddo
      do i=1,mcmcar
        do j=1,mcmcar
          hx(i,j)=0.d0
        enddo
      enddo
c
c  Initialize tranky
c
      do j=1,mcmkey
        tranky(j) = ' '
      enddo
c
c  Transform the geometry into angstrom and real
c
      mcncar=mcnatm*3                                                   OT
c
      do i=1,mcncar                                                     OT
        transx(i)=sngl(xii(i)*fboan)
      enddo
c
c 1030HL03s
c intinialization of MM                                                 1201HL03
      enertk=0.0                                                        1201HL03
      do j=1,mcmcar                                                     1201HL03
         dxtk(j)=0.0                                                    1201HL03
         do l=1,mcmcar                                                  1201HL03
            ftk(j,l)=0.0                                                1201HL03
         enddo                                                          1201HL03
      enddo                                                             1201HL03
      do j=1,mcmatm                                                     1201HL03
         itgtn(j)=0                                                     1201HL03
         itptn(j)=0                                                     1201HL03
         atnmtn(j)=' '                                                  1201HL03
         intn(j)=0                                                      1201HL03
         do l=1,mcmatm                                                  1201HL03
            ic12tn(l,j)=0                                               1201HL03
         enddo                                                          1201HL03
      enddo                                                             1201HL03
c 1030HL03e
c
c  Put variables in the right arrays
c
      do 20 j=1,mcnatm
         itgtn(j)=itags(j,iconf,iperm)                                  1106OT06
         itptn(j)=itype(j,iconf,iperm)                                  1106OT06
         atnmtn(j)=atname(j,iconf,iperm)                                1106OT06
         intn(j)=incon(j,iconf,iperm)                                   1106OT06
         do l=1,mcnatm
            ic12tn(l,j)=icon12(l,j,iconf,iperm)                         1106OT06
         enddo
 20   continue
c
      tnky=inky(iconf,iperm)                                            1106OT06
      do j=1,tnky
         tranky(j) = inkl(j,iconf,iperm)                                1106OT06
      enddo
c
c  Do the appropriate calculations (energy if itypec=1, gradients if
c  itypec=2, or gradients and Hessians if itypec=3)
c
      if (itypec.eq.1) then
         call energ(transx,ic12tn,atnmtn,itptn,itgtn,mcmkey,
     *              intn,mcnatm,mcmatm,mcmcar,tnky,tranky,
     *              enertk)
      else if (itypec.eq.2) then
         call grads(transx,ic12tn,atnmtn,itptn,itgtn,mcmkey,
     *              intn,mcnatm,mcmatm,mcmcar,tnky,tranky,
     *              dxtk,enertk)
      else if (itypec.eq.3) then
         call grads(transx,ic12tn,atnmtn,itptn,itgtn,mcmkey,
     *              intn,mcnatm,mcmatm,mcmcar,tnky,tranky,
     *              dxtk,enertk)
         call hesss(transx,ic12tn,atnmtn,itptn,itgtn,mcmkey,
     *              intn,mcnatm,mcmatm,mcmcar,tnky,tranky,
     *              ftk)
      endif
c
c  Transform to double precision and atomic units, correct the energy, 
c  and put in the right arrays
c
      if (iconf.eq.1) then
         ex=dble(enertk)/fhakc - vz1
c
      else if (iconf.eq.2) then
         ex=dble(enertk)/fhakc + ediff0 - vz2
      else
         ex=dble(enertk)/fhakc
      endif
c
c
      do i=1,mcncar                                                         OT
         gx(i)=dble(dxtk(i))*fboan/fhakc
      enddo
c
      do i=1,mcncar                                                         OT
         do j=1,mcncar                                                      OT
            hx(i,j)=dble(ftk(i,j))*(fboan**2.d0)/fhakc
         enddo
      enddo
c
      return
      end
c***********************************************************************
c     mcwscales
c***********************************************************************
c
      subroutine mcwscales
c
c     This subroutine calculates scaling coefficients F_k for the weight function w_k.
c     (added by O.T. in May 2008)
c
      implicit double precision (a-h, o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      dimension dqsw(mcmics,mcmesp+2)
      dimension dqsw_12(mcmics,mcmesp+2)
      dimension dqsw_23(mcmics,mcmesp+2)
      dimension dqsw_13(mcmics,mcmesp+2)
      dimension dqsw_123(mcmics,mcmesp+2)
      dimension dqsw_132(mcmics,mcmesp+2)
      dimension F(mcmesp)
      dimension F_12(mcmesp)
      dimension F_23(mcmesp)
      dimension F_13(mcmesp)
      dimension F_123(mcmesp)
      dimension F_132(mcmesp)
      dimension cat(mcmesp)
      dimension cat_12(mcmesp)
      dimension cat_13(mcmesp)
      dimension cat_23(mcmesp)
      dimension cat_123(mcmesp)
      dimension cat_132(mcmesp)
c
c
      dimension e12pf(mcmesp),e12p(mcmesp)
      dimension e12pf_12(mcmesp),
     *          e12p_12(mcmesp)
      dimension e12pf_23(mcmesp),
     *          e12p_23(mcmesp)
      dimension e12pf_13(mcmesp),
     *          e12p_13(mcmesp)
      dimension e12pf_123(mcmesp),
     *          e12p_123(mcmesp)
      dimension e12pf_132(mcmesp),
     *          e12p_132(mcmesp)
      dimension wrk(mcmics),wrk1(mcmics)
      dimension wrk_12(mcmics),wrk1_12(mcmics)                          
      dimension wrk_23(mcmics),wrk1_23(mcmics)                          
      dimension wrk_13(mcmics),wrk1_13(mcmics)                          
      dimension wrk_123(mcmics),wrk1_123(mcmics)                        
      dimension wrk_132(mcmics),wrk1_132(mcmics)                        
c
      zero = 0.d0
c 
c     zero out Shepard variables
c
      do i=1,mcmics
        do j=1,mcmesp+2
          dqsw(i,j) =  0.d0
          dqsw_12(i,j) =  0.d0
          dqsw_23(i,j) =  0.d0
          dqsw_13(i,j) =  0.d0
          dqsw_123(i,j) =  0.d0
          dqsw_132(i,j) =  0.d0
        enddo
      enddo
c      do i=1,mcmesp+2
      do i=1,mcmesp
c        e12pnt(i) = 0.0d0
        e12pf(i) = 0.0d0
        e12p(i) = 0.0d0
c        e12pnt_12(i) = 0.0d0                                            
        e12pf_12(i) = 0.0d0                                             
        e12p_12(i) = 0.0d0                                              
c        e12pnt_23(i) = 0.0d0                                            
        e12pf_23(i) = 0.0d0                                             
        e12p_23(i) = 0.0d0                                              
c        e12pnt_13(i) = 0.0d0                                            
        e12pf_13(i) = 0.0d0                                             
        e12p_13(i) = 0.0d0                                              
c        e12pnt_123(i) = 0.0d0                                           
        e12pf_123(i) = 0.0d0                                            
        e12p_123(i) = 0.0d0                                             
c        e12pnt_132(i) = 0.0d0                                           
        e12pf_132(i) = 0.0d0                                            
        e12p_132(i) = 0.0d0                                             
      enddo       
       do i=1,mcmesp                                                    
        F(i)=0.0d0
        F_12(i)=0.0d0
        F_23(i)=0.0d0
        F_13(i)=0.0d0
        F_123(i)=0.0d0
        F_132(i)=0.0d0
        cat(i)=0.0d0
        cat_12(i)=0.0d0
        cat_23(i)=0.0d0
        cat_13(i)=0.0d0
        cat_123(i)=0.0d0
        cat_132(i)=0.0d0
        enddo     
        do i=1,mcmesp*6
        Fw(i)=0.d0
        enddo
c
       e12 = zero
       e12_12 = zero                                                    
       e12_23 = zero                                                    
       e12_13 = zero                                                    
       e12_123 = zero                                                   
       e12_132 = zero                                                   
             e12a= zero                                                 
             e12b= zero                                                 
             e12c= zero                                                 
             e12d= zero                                                 
             e12e= zero                                                 
             e12f= zero                                                 
c
c     calculate the displacement in internal coordinates used for
c     generalized distances
c
       do j=1,mcnesp+2
         do i=1,mcnics
          dqsw(i,j)=qd(i)-qs0(i,j)
          dqsw_12(i,j)=qd(i)-qs0_12(i,j)                                 
          dqsw_23(i,j)=qd(i)-qs0_23(i,j)                                 
          dqsw_13(i,j)=qd(i)-qs0_13(i,j)                                 
          dqsw_123(i,j)=qd(i)-qs0_123(i,j)                               
          dqsw_132(i,j)=qd(i)-qs0_132(i,j)                               
         enddo
         if (mcndas.gt.0) then
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas
               if (dqsw(i,j).lt.-fpi) then
                   dqsw(i,j) = dqsw(i,j)+2.0d0*fpi
               elseif (dqsw(i,j).gt.fpi) then
                   dqsw(i,j) = dqsw(i,j)-2.0d0*fpi
               endif
            enddo
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas                 
               if (dqsw_12(i,j).lt.-fpi) then                            
                   dqsw_12(i,j) = dqsw_12(i,j)+2.0d0*fpi                  
               elseif (dqsw_12(i,j).gt.fpi) then                         
                   dqsw_12(i,j) = dqsw_12(i,j)-2.0d0*fpi                  
               endif                                                    
            enddo                                                       
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas                 
               if (dqsw_23(i,j).lt.-fpi) then                            
                   dqsw_23(i,j) = dqsw_23(i,j)+2.0d0*fpi                  
               elseif (dqsw_23(i,j).gt.fpi) then                         
                   dqsw_23(i,j) = dqsw_23(i,j)-2.0d0*fpi                  
               endif                                                    
            enddo                                                       
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas                 
               if (dqsw_13(i,j).lt.-fpi) then                            
                   dqsw_13(i,j) = dqsw_13(i,j)+2.0d0*fpi                  
               elseif (dqsw_13(i,j).gt.fpi) then                         
                   dqsw_13(i,j) = dqsw_13(i,j)-2.0d0*fpi                  
               endif                                                    
            enddo                                                       
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas                 
               if (dqsw_123(i,j).lt.-fpi) then                           
                   dqsw_123(i,j) = dqsw_123(i,j)+2.0d0*fpi                
               elseif (dqsw_123(i,j).gt.fpi) then                        
                   dqsw_123(i,j) = dqsw_123(i,j)-2.0d0*fpi                
               endif                                                    
            enddo                                                       
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas                 
               if (dqsw_132(i,j).lt.-fpi) then                           
                   dqsw_132(i,j) = dqsw_132(i,j)+2.0d0*fpi                
               elseif (dqsw_132(i,j).gt.fpi) then                        
                   dqsw_132(i,j) = dqsw_132(i,j)-2.0d0*fpi                
               endif                                                    
            enddo                                                       
         endif
      enddo
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
      do mciesp=1,mcnesp
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
          btrm_12=0.d0                                                  
          btrm_23=0.d0                                                  
          btrm_13=0.d0                                                  
          btrm_123=0.d0                                                 
          btrm_132=0.d0                                                 
          ctrm_12=0.d0                                                  
          ctrm_23=0.d0                                                  
          ctrm_13=0.d0                                                  
          ctrm_123=0.d0                                                 
          ctrm_132=0.d0                                                 
          qtrm_12=0.d0                                                  
          be12=0.d0                                                     
          be12_12=0.d0                                                  
          be12_23=0.d0                                                  
          be12_13=0.d0                                                  
          be12_123=0.d0                                                 
          be12_132=0.d0                                                 
c
          do i=1,mcnics
            wrk(i) =0.d0
            wrk_12(i) =0.d0                                             
            wrk_23(i) =0.d0                                             
            wrk_13(i) =0.d0                                             
            wrk_123(i) =0.d0                                            
            wrk_132(i) =0.d0                                            
            btrm=btrm+bevbm(i,mciesp)*dqsw(i,mciesp)                     
            btrm_12=btrm_12+bevbm_12(i,mciesp)*dqsw_12(i,mciesp)          
            btrm_23=btrm_23+bevbm_23(i,mciesp)*dqsw_23(i,mciesp)         
            btrm_13=btrm_13+bevbm_13(i,mciesp)*dqsw_13(i,mciesp)         
            btrm_123=btrm_123+bevbm_123(i,mciesp)*dqsw_123(i,mciesp)     
            btrm_132=btrm_132+bevbm_132(i,mciesp)*dqsw_132(i,mciesp)     
            do j=1,mcnics
              wrk(i)=wrk(i)+dqsw(j,mciesp)*cevbm(i,j,mciesp)
          wrk_12(i)=wrk_12(i)+dqsw_12(j,mciesp)*cevbm_12(i,j,mciesp)     
          wrk_23(i)=wrk_23(i)+dqsw_23(j,mciesp)*cevbm_23(i,j,mciesp)     
          wrk_13(i)=wrk_13(i)+dqsw_13(j,mciesp)*cevbm_13(i,j,mciesp)     
          wrk_123(i)=wrk_123(i)+dqsw_123(j,mciesp)*cevbm_123(i,j,mciesp) 
          wrk_132(i)=wrk_132(i)+dqsw_132(j,mciesp)*cevbm_132(i,j,mciesp) 
            enddo
            ctrm=ctrm+dqsw(i,mciesp)*wrk(i)
            ctrm_12=ctrm_12+dqsw_12(i,mciesp)*wrk_12(i)                  
            ctrm_23=ctrm_23+dqsw_23(i,mciesp)*wrk_23(i)                  
            ctrm_13=ctrm_13+dqsw_13(i,mciesp)*wrk_13(i)                  
            ctrm_123=ctrm_123+dqsw_123(i,mciesp)*wrk_123(i)              
            ctrm_132=ctrm_132+dqsw_132(i,mciesp)*wrk_132(i)              
          enddo
c
c     Added to avoid negative values for V12**2 term, 4/14/99 by Y. Kim
c
cc          delta = 0.00000001d0
c            udelta = 0.00016d0
            udelta = 0.0000000256d0
            unn = 2.d0
          be12 = 1.d0+btrm+0.5d0*ctrm
          be12_12 = 1.d0+btrm_12+0.5d0*ctrm_12                            
          be12_23 = 1.d0+btrm_23+0.5d0*ctrm_23                             
          be12_13 = 1.d0+btrm_13+0.5d0*ctrm_13                             
          be12_123 = 1.d0+btrm_123+0.5d0*ctrm_123                         
          be12_132 = 1.d0+btrm_132+0.5d0*ctrm_132                         
          e12p(mciesp) = aevbm(mciesp)*be12
          e12p_12(mciesp) = aevbm(mciesp)*be12_12                       
          e12p_23(mciesp) = aevbm(mciesp)*be12_23                       
          e12p_13(mciesp) = aevbm(mciesp)*be12_13                       
          e12p_123(mciesp) = aevbm(mciesp)*be12_123                     
          e12p_132(mciesp) = aevbm(mciesp)*be12_132                     
c
        enddo
          A=0.0006d0
c           A=1000.0006d0
          s=4.0d0
c          s=2.0d0
          do mciesp=1,mcnesp
          cat(mciesp)=abs(e12p(mciesp))-abs(aevbm(mciesp))
          F(mciesp)=1.d0/(1.d0+(cat(mciesp)/A)**s)
          cat_12(mciesp)=abs(e12p_12(mciesp))-abs(aevbm(mciesp))
          F_12(mciesp)=1.d0/(1.d0+(cat_12(mciesp)/A)**s)
          cat_23(mciesp)=abs(e12p_23(mciesp))-abs(aevbm(mciesp))
          F_23(mciesp)=1.d0/(1.d0+(cat_23(mciesp)/A)**s)
          cat_13(mciesp)=abs(e12p_13(mciesp))-abs(aevbm(mciesp))
          F_13(mciesp)=1.d0/(1.d0+(cat_13(mciesp)/A)**s)
          cat_123(mciesp)=abs(e12p_123(mciesp))-abs(aevbm(mciesp))
          F_123(mciesp)=1.d0/(1.d0+
     *    (cat_123(mciesp)/A)**s)
          cat_132(mciesp)=abs(e12p_132(mciesp))-abs(aevbm(mciesp))
          F_132(mciesp)=1.d0/(1.d0+
     *    (cat_132(mciesp)/A)**s)
c          write (6,*) "F nonHerm", F(mciesp),F_12(mciesp),F_23(mciesp),
c     &    F_13(mciesp),F_123(mciesp),F_132(mciesp)
c
        enddo
          do i=1,mcnesp
          Fw(i)=F(i)
          enddo
          do i=1,mcnesp
          Fw(i+mcnesp)=F_12(i)
          enddo
          do i=1,mcnesp
          Fw(i+mcnesp*2)=F_23(i)
          enddo
          do i=1,mcnesp
          Fw(i+mcnesp*3)=F_13(i)
          enddo
          do i=1,mcnesp
          Fw(i+mcnesp*4)=F_123(i)
          enddo
          do i=1,mcnesp
          Fw(i+mcnesp*5)=F_132(i)
          enddo
c
      return                                                            
      end 
c***********************************************************************
c     mcwscales1
c***********************************************************************
c
      subroutine mcwscales1
c
c     This subroutine calculates scaling coefficients F_k for the weight function w_k.
c     (added by O.T. in May 2008)
c
      implicit double precision (a-h, o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      dimension dqsw(mcmics,mcmesp+2)
      dimension dqsw_12(mcmics,mcmesp+2)
      dimension dqsw_23(mcmics,mcmesp+2)
      dimension dqsw_13(mcmics,mcmesp+2)
      dimension dqsw_123(mcmics,mcmesp+2)
      dimension dqsw_132(mcmics,mcmesp+2)
      dimension F(mcmesp)
      dimension F_12(mcmesp)
      dimension F_23(mcmesp)
      dimension F_13(mcmesp)
      dimension F_123(mcmesp)
      dimension F_132(mcmesp)
      dimension cat(mcmesp)
      dimension cat_12(mcmesp)
      dimension cat_13(mcmesp)
      dimension cat_23(mcmesp)
      dimension cat_123(mcmesp)
      dimension cat_132(mcmesp)
c
c
      dimension e12pf(mcmesp),e12p(mcmesp)
      dimension e12pf_12(mcmesp),
     *          e12p_12(mcmesp)
      dimension e12pf_23(mcmesp),
     *          e12p_23(mcmesp)
      dimension e12pf_13(mcmesp),
     *          e12p_13(mcmesp)
      dimension e12pf_123(mcmesp),
     *          e12p_123(mcmesp)
      dimension e12pf_132(mcmesp),
     *          e12p_132(mcmesp)
      dimension wrk(mcmics),wrk1(mcmics)
      dimension wrk_12(mcmics),wrk1_12(mcmics)                          
      dimension wrk_23(mcmics),wrk1_23(mcmics)                          
      dimension wrk_13(mcmics),wrk1_13(mcmics)                          
      dimension wrk_123(mcmics),wrk1_123(mcmics)                        
      dimension wrk_132(mcmics),wrk1_132(mcmics)                        
c
      zero = 0.d0
c 
c     zero out Shepard variables
c
      do i=1,mcmics
        do j=1,mcmesp+2
          dqsw(i,j) =  0.d0
          dqsw_12(i,j) =  0.d0
          dqsw_23(i,j) =  0.d0
          dqsw_13(i,j) =  0.d0
          dqsw_123(i,j) =  0.d0
          dqsw_132(i,j) =  0.d0
        enddo
      enddo
c      do i=1,mcmesp+2
      do i=1,mcmesp
c        e12pnt(i) = 0.0d0
        e12pf(i) = 0.0d0
        e12p(i) = 0.0d0
c        e12pnt_12(i) = 0.0d0                                            
        e12pf_12(i) = 0.0d0                                             
        e12p_12(i) = 0.0d0                                              
c        e12pnt_23(i) = 0.0d0                                            
        e12pf_23(i) = 0.0d0                                             
        e12p_23(i) = 0.0d0                                              
c        e12pnt_13(i) = 0.0d0                                            
        e12pf_13(i) = 0.0d0                                             
        e12p_13(i) = 0.0d0                                              
c        e12pnt_123(i) = 0.0d0                                           
        e12pf_123(i) = 0.0d0                                            
        e12p_123(i) = 0.0d0                                             
c        e12pnt_132(i) = 0.0d0                                           
        e12pf_132(i) = 0.0d0                                            
        e12p_132(i) = 0.0d0                                             
      enddo       
       do i=1,mcmesp                                                    
        F(i)=0.0d0
        F_12(i)=0.0d0
        F_23(i)=0.0d0
        F_13(i)=0.0d0
        F_123(i)=0.0d0
        F_132(i)=0.0d0
        cat(i)=0.0d0
        cat_12(i)=0.0d0
        cat_23(i)=0.0d0
        cat_13(i)=0.0d0
        cat_123(i)=0.0d0
        cat_132(i)=0.0d0
        enddo     
        do i=1,mcmesp*6
        Fw(i)=0.d0
        enddo
c
       e12 = zero
       e12_12 = zero                                                    
       e12_23 = zero                                                    
       e12_13 = zero                                                    
       e12_123 = zero                                                   
       e12_132 = zero                                                   
             e12a= zero                                                 
             e12b= zero                                                 
             e12c= zero                                                 
             e12d= zero                                                 
             e12e= zero                                                 
             e12f= zero                                                 
c
c     calculate the displacement in internal coordinates used for
c     generalized distances
c
       do j=1,mcnesp+2
         do i=1,mcnics
          dqsw(i,j)=qd(i)-qs0(i,j)
          dqsw_12(i,j)=qd(i)-qs0_12(i,j)                                 
          dqsw_23(i,j)=qd(i)-qs0_23(i,j)                                 
          dqsw_13(i,j)=qd(i)-qs0_13(i,j)                                 
          dqsw_123(i,j)=qd(i)-qs0_123(i,j)                               
          dqsw_132(i,j)=qd(i)-qs0_132(i,j)                               
         enddo
         if (mcndas.gt.0) then
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas
               if (dqsw(i,j).lt.-fpi) then
                   dqsw(i,j) = dqsw(i,j)+2.0d0*fpi
               elseif (dqsw(i,j).gt.fpi) then
                   dqsw(i,j) = dqsw(i,j)-2.0d0*fpi
               endif
            enddo
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas                 
               if (dqsw_12(i,j).lt.-fpi) then                            
                   dqsw_12(i,j) = dqsw_12(i,j)+2.0d0*fpi                  
               elseif (dqsw_12(i,j).gt.fpi) then                         
                   dqsw_12(i,j) = dqsw_12(i,j)-2.0d0*fpi                  
               endif                                                    
            enddo                                                       
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas                 
               if (dqsw_23(i,j).lt.-fpi) then                            
                   dqsw_23(i,j) = dqsw_23(i,j)+2.0d0*fpi                  
               elseif (dqsw_23(i,j).gt.fpi) then                         
                   dqsw_23(i,j) = dqsw_23(i,j)-2.0d0*fpi                  
               endif                                                    
            enddo                                                       
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas                 
               if (dqsw_13(i,j).lt.-fpi) then                            
                   dqsw_13(i,j) = dqsw_13(i,j)+2.0d0*fpi                  
               elseif (dqsw_13(i,j).gt.fpi) then                         
                   dqsw_13(i,j) = dqsw_13(i,j)-2.0d0*fpi                  
               endif                                                    
            enddo                                                       
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas                 
               if (dqsw_123(i,j).lt.-fpi) then                           
                   dqsw_123(i,j) = dqsw_123(i,j)+2.0d0*fpi                
               elseif (dqsw_123(i,j).gt.fpi) then                        
                   dqsw_123(i,j) = dqsw_123(i,j)-2.0d0*fpi                
               endif                                                    
            enddo                                                       
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas                 
               if (dqsw_132(i,j).lt.-fpi) then                           
                   dqsw_132(i,j) = dqsw_132(i,j)+2.0d0*fpi                
               elseif (dqsw_132(i,j).gt.fpi) then                        
                   dqsw_132(i,j) = dqsw_132(i,j)-2.0d0*fpi                
               endif                                                    
            enddo                                                       
         endif
      enddo
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
      do mciesp=1,mcnesp
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
          btrm_12=0.d0                                                  
          btrm_23=0.d0                                                  
          btrm_13=0.d0                                                  
          btrm_123=0.d0                                                 
          btrm_132=0.d0                                                 
          ctrm_12=0.d0                                                  
          ctrm_23=0.d0                                                  
          ctrm_13=0.d0                                                  
          ctrm_123=0.d0                                                 
          ctrm_132=0.d0                                                 
          qtrm_12=0.d0                                                  
          be12=0.d0                                                     
          be12_12=0.d0                                                  
          be12_23=0.d0                                                  
          be12_13=0.d0                                                  
          be12_123=0.d0                                                 
          be12_132=0.d0                                                 
c
          do i=1,mcnics
            wrk(i) =0.d0
            wrk_12(i) =0.d0                                             
            wrk_23(i) =0.d0                                             
            wrk_13(i) =0.d0                                             
            wrk_123(i) =0.d0                                            
            wrk_132(i) =0.d0                                            
            btrm=btrm+bevbm(i,mciesp)*dqsw(i,mciesp)                     
            btrm_12=btrm_12+bevbm_12(i,mciesp)*dqsw_12(i,mciesp)          
            btrm_23=btrm_23+bevbm_23(i,mciesp)*dqsw_23(i,mciesp)         
            btrm_13=btrm_13+bevbm_13(i,mciesp)*dqsw_13(i,mciesp)         
            btrm_123=btrm_123+bevbm_123(i,mciesp)*dqsw_123(i,mciesp)     
            btrm_132=btrm_132+bevbm_132(i,mciesp)*dqsw_132(i,mciesp)     
            do j=1,mcnics
              wrk(i)=wrk(i)+dqsw(j,mciesp)*cevbm(i,j,mciesp)
          wrk_12(i)=wrk_12(i)+dqsw_12(j,mciesp)*cevbm_12(i,j,mciesp)     
          wrk_23(i)=wrk_23(i)+dqsw_23(j,mciesp)*cevbm_23(i,j,mciesp)     
          wrk_13(i)=wrk_13(i)+dqsw_13(j,mciesp)*cevbm_13(i,j,mciesp)     
          wrk_123(i)=wrk_123(i)+dqsw_123(j,mciesp)*cevbm_123(i,j,mciesp) 
          wrk_132(i)=wrk_132(i)+dqsw_132(j,mciesp)*cevbm_132(i,j,mciesp) 
            enddo
            ctrm=ctrm+dqsw(i,mciesp)*wrk(i)
            ctrm_12=ctrm_12+dqsw_12(i,mciesp)*wrk_12(i)                  
            ctrm_23=ctrm_23+dqsw_23(i,mciesp)*wrk_23(i)                  
            ctrm_13=ctrm_13+dqsw_13(i,mciesp)*wrk_13(i)                  
            ctrm_123=ctrm_123+dqsw_123(i,mciesp)*wrk_123(i)              
            ctrm_132=ctrm_132+dqsw_132(i,mciesp)*wrk_132(i)              
          enddo
c
c     Added to avoid negative values for V12**2 term, 4/14/99 by Y. Kim
c
cc          delta = 0.00000001d0
c            udelta = 0.00016d0
            udelta = 0.0000000256d0
            unn = 2.d0
          be12 = 1.d0+btrm+0.5d0*ctrm
          be12_12 = 1.d0+btrm_12+0.5d0*ctrm_12                            
          be12_23 = 1.d0+btrm_23+0.5d0*ctrm_23                             
          be12_13 = 1.d0+btrm_13+0.5d0*ctrm_13                             
          be12_123 = 1.d0+btrm_123+0.5d0*ctrm_123                         
          be12_132 = 1.d0+btrm_132+0.5d0*ctrm_132                         
          e12p(mciesp) = aevbm(mciesp)*be12
          e12p_12(mciesp) = aevbm(mciesp)*be12_12                       
          e12p_23(mciesp) = aevbm(mciesp)*be12_23                       
          e12p_13(mciesp) = aevbm(mciesp)*be12_13                       
          e12p_123(mciesp) = aevbm(mciesp)*be12_123                     
          e12p_132(mciesp) = aevbm(mciesp)*be12_132                     
c
          if (e12p(mciesp).gt.0.0d0) then
cc            fixf = dexp(-delta/e12p(mciesp))
              fixf = 1.d0/(1.d0+(udelta/e12p(mciesp))**unn)
          else
            fixf = 0.0d0
          endif
          if (e12p_12(mciesp).gt.0.0d0) then                            
cc           fixf_12 = dexp(-delta/e12p_12(mciesp))                      
           fixf_12 = 1.d0/(1.d0+(udelta/e12p_12(mciesp))**unn)
          else                                                          
            fixf_12 = 0.0d0                                             
          endif                                                         
          if (e12p_23(mciesp).gt.0.0d0) then                            
cc            fixf_23 = dexp(-udelta/e12p_23(mciesp))                      
           fixf_23 = 1.d0/(1.d0+(udelta/e12p_23(mciesp))**unn)
          else                                                          
            fixf_23 = 0.0d0                                             
          endif                                                         
          if (e12p_13(mciesp).gt.0.0d0) then                            
cc            fixf_13 = dexp(-udelta/e12p_13(mciesp))                      
           fixf_13 = 1.d0/(1.d0+(udelta/e12p_13(mciesp))**unn)
          else                                                          
            fixf_13 = 0.0d0                                             
          endif                                                         
          if (e12p_123(mciesp).gt.0.0d0) then                           
cc            fixf_123 = dexp(-udelta/e12p_123(mciesp))                    
           fixf_123 = 1.d0/(1.d0+(udelta/e12p_123(mciesp))**unn)
          else                                                          
            fixf_123 = 0.0d0                                            
          endif                                                         
          if (e12p_132(mciesp).gt.0.0d0) then                           
cc            fixf_132 = dexp(-udelta/e12p_132(mciesp))                    
           fixf_132 = 1.d0/(1.d0+(udelta/e12p_132(mciesp))**unn)
          else                                                          
            fixf_132 = 0.0d0                                            
          endif                                                         
          e12pf(mciesp) = e12p(mciesp)*fixf                             
          e12pf_12(mciesp) = e12p_12(mciesp)*fixf_12                    
          e12pf_23(mciesp) = e12p_23(mciesp)*fixf_23                    
          e12pf_13(mciesp) = e12p_13(mciesp)*fixf_13                    
          e12pf_123(mciesp) = e12p_123(mciesp)*fixf_123                 
          e12pf_132(mciesp) = e12p_132(mciesp)*fixf_132                 
c
cc          e12pnt(mciesp) = dsqrt(e12pf(mciesp))                         
cc          e12pnt_12(mciesp) = dsqrt(e12pf_12(mciesp))                   
cc          e12pnt_23(mciesp) = dsqrt(e12pf_23(mciesp))                   
cc          e12pnt_13(mciesp) = dsqrt(e12pf_13(mciesp))                   
cc          e12pnt_123(mciesp) = dsqrt(e12pf_123(mciesp))                 
cc          e12pnt_132(mciesp) = dsqrt(e12pf_132(mciesp))                 
c
        enddo
          A=0.0006d0
c           A=1000.0006d0
          s=4.0d0
c          s=2.0d0
          do mciesp=1,mcnesp
          cat(mciesp)=abs(e12pf(mciesp))-abs(aevbm(mciesp))
          F(mciesp)=1.d0/(1.d0+(cat(mciesp)/A)**s)
          cat_12(mciesp)=abs(e12pf_12(mciesp))-abs(aevbm(mciesp))
          F_12(mciesp)=1.d0/(1.d0+(cat_12(mciesp)/A)**s)
          cat_23(mciesp)=abs(e12pf_23(mciesp))-abs(aevbm(mciesp))
          F_23(mciesp)=1.d0/(1.d0+(cat_23(mciesp)/A)**s)
          cat_13(mciesp)=abs(e12pf_13(mciesp))-abs(aevbm(mciesp))
          F_13(mciesp)=1.d0/(1.d0+(cat_13(mciesp)/A)**s)
          cat_123(mciesp)=abs(e12pf_123(mciesp))-abs(aevbm(mciesp))
          F_123(mciesp)=1.d0/(1.d0+
     *    (cat_123(mciesp)/A)**s)
          cat_132(mciesp)=abs(e12pf_132(mciesp))-abs(aevbm(mciesp))
          F_132(mciesp)=1.d0/(1.d0+
     *    (cat_132(mciesp)/A)**s)
          write (*,*) "F", F(mciesp),F_12(mciesp),F_23(mciesp),
     &    F_13(mciesp),F_123(mciesp),F_132(mciesp)
c
        enddo
          do i=1,mcnesp
          Fw(i)=F(i)
          enddo
          do i=1,mcnesp
          Fw(i+mcnesp)=F_12(i)
          enddo
          do i=1,mcnesp
          Fw(i+mcnesp*2)=F_23(i)
          enddo
          do i=1,mcnesp
          Fw(i+mcnesp*3)=F_13(i)
          enddo
          do i=1,mcnesp
          Fw(i+mcnesp*4)=F_123(i)
          enddo
          do i=1,mcnesp
          Fw(i+mcnesp*5)=F_132(i)
          enddo
c
      return                                                            
      end 
c***********************************************************************
c     mcwscale
c***********************************************************************
c
      subroutine mcwscale
c
c     This subroutine calculates scaling coefficients F_k for the weight function w_k.
c     (added by O.T. in May 2008)
c
      implicit double precision (a-h, o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      dimension dqsw(mcmics,mcmesp+2)
      dimension F(mcmesp)
      dimension cat(mcmesp)
c
      dimension e12pnt(mcmesp),e12pf(mcmesp),e12p(mcmesp)
      dimension wrk(mcmics),wrk1(mcmics)
c
      zero = 0.d0
c 
c     zero out Shepard variables
c
      do i=1,mcmics
        do j=1,mcmesp+2
          dqsw(i,j) =  0.d0
        enddo
      enddo
      do i=1,mcmesp
        e12pnt(i) = 0.0d0
        e12pf(i) = 0.0d0
        e12p(i) = 0.0d0
      enddo       
       do i=1,mcmesp                                                    
        F(i)=0.0d0
        cat(i)=0.0d0
       enddo     
        do i=1,mcmesp
        Fw(i)=0.d0
        enddo
c
       e12 = zero
c
c     calculate the displacement in internal coordinates used for
c     generalized distances
c
       do j=1,mcnesp+2
         do i=1,mcnics
          dqsw(i,j)=qd(i)-qs0(i,j)
         enddo
         if (mcndas.gt.0) then
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas
               if (dqsw(i,j).lt.-fpi) then
                   dqsw(i,j) = dqsw(i,j)+2.0d0*fpi
               elseif (dqsw(i,j).gt.fpi) then
                   dqsw(i,j) = dqsw(i,j)-2.0d0*fpi
               endif
            enddo
         endif
      enddo
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
      do mciesp=1,mcnesp
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)*dqsw(i,mciesp)                     
            do j=1,mcnics
              wrk(i)=wrk(i)+dqsw(j,mciesp)*cevbm(i,j,mciesp)
            enddo
            ctrm=ctrm+dqsw(i,mciesp)*wrk(i)
          enddo
c
c
c            udelta = 0.0000000256d0
c            unn = 2.d0
          be12 = 1.d0+btrm+0.5d0*ctrm
          e12p(mciesp) = aevbm(mciesp)*be12
c
        enddo
           A=1000.5d0
c            A=0.0005d0
c          s=4.0d0
          s=2.0d0
          do mciesp=1,mcnesp
          cat(mciesp)=abs(e12p(mciesp))-abs(aevbm(mciesp))
          F(mciesp)=1.d0/(1.d0+(cat(mciesp)/A)**s)
c          write (*,*) "F", F(mciesp)
c
        enddo
          do i=1,mcnesp
          Fw(i)=F(i)
          enddo
c
      return                                                            
      end 
c***********************************************************************
c     mcwscale1
c***********************************************************************
c
c      subroutine mcwscale1(e12,gi12,hi12,itypec)
      subroutine mcwscale1
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).
c
      implicit double precision (a-h, o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      dimension dqsw(mcmics,mcmesp+2)
      dimension F(mcmesp)
      dimension cat(mcmesp)
c
      dimension e12pnt(mcmesp),e12pf(mcmesp),e12p(mcmesp)
      dimension wrk(mcmics),wrk1(mcmics)
c
      dimension uterm(mcmesp)
c 
c     zero out Shepard variables
c
      do i=1,mcmics
        do j=1,mcmesp+2
          dqsw(i,j) =  0.d0
        enddo
      enddo
       do i=1,mcmesp
        e12pnt(i) = 0.0d0
        e12pf(i) = 0.0d0
        e12p(i) = 0.0d0
        uterm(i) = 0.0d0
      enddo
c
c     calculate the displacement in internal coordinates used for
c     Shepard interpolation
c
      do j=1,mcnesp+2
         do i=1,mcnics
            dqsw(i,j)=qs(i)-qs0(i,j)
         enddo
         if (mcndas.gt.0) then
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas
               if (dqsw(i,j).lt.-fpi) then
                   dqsw(i,j) = dqsw(i,j)+2.0d0*fpi
               elseif (dqsw(i,j).gt.fpi) then
                   dqsw(i,j) = dqsw(i,j)-2.0d0*fpi
               endif
            enddo
         endif
      enddo
c
c
c
      do mciesp=1,mcnesp
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)*dqsw(i,mciesp)
            do j=1,mcnics
              wrk(i)=wrk(i)+dqsw(j,mciesp)*cevbm(i,j,mciesp)
            enddo
            ctrm=ctrm+dqsw(i,mciesp)*wrk(i)
          enddo
c
c     Added to avoid negative values for V12**2 term, 4/14/99 by Y. Kim
c
c          delta = 0.00000001d0
c           udelta = 0.0000000256d0
c           unn = 2
          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
       enddo

           A=1000.5d0
c            A=0.0005d0
c          s=4.0d0
          s=2.0d0
          do mciesp=1,mcnesp
          cat(mciesp)=abs(e12pf(mciesp))-abs(aevbm(mciesp))
          F(mciesp)=1.d0/(1.d0+(cat(mciesp)/A)**s)
c          write (*,*) "F", F(mciesp)
c
        enddo
          do i=1,mcnesp
          Fw(i)=F(i)
          enddo
      return
      end
c***********************************************************************
c     mcwscales1st
c***********************************************************************
c
      subroutine mcwscales1st
c
c     This subroutine calculates scaling coefficients F_k for the weight function w_k.
c     (added by O.T. in May 2008)
c
      implicit double precision (a-h, o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      dimension dqsw(mcmics,mcmesp+2)
      dimension dqsw_12(mcmics,mcmesp+2)
      dimension dqsw_23(mcmics,mcmesp+2)
      dimension dqsw_13(mcmics,mcmesp+2)
      dimension dqsw_123(mcmics,mcmesp+2)
      dimension dqsw_132(mcmics,mcmesp+2)
      dimension F(mcmesp)
      dimension F_12(mcmesp)
      dimension F_23(mcmesp)
      dimension F_13(mcmesp)
      dimension F_123(mcmesp)
      dimension F_132(mcmesp)
      dimension cat(mcmesp)
      dimension cat_12(mcmesp)
      dimension cat_13(mcmesp)
      dimension cat_23(mcmesp)
      dimension cat_123(mcmesp)
      dimension cat_132(mcmesp)
c
c
      dimension e12pf(mcmesp),e12p(mcmesp)
      dimension e12pf_12(mcmesp),
     *          e12p_12(mcmesp)
      dimension e12pf_23(mcmesp),
     *          e12p_23(mcmesp)
      dimension e12pf_13(mcmesp),
     *          e12p_13(mcmesp)
      dimension e12pf_123(mcmesp),
     *          e12p_123(mcmesp)
      dimension e12pf_132(mcmesp),
     *          e12p_132(mcmesp)
c      dimension wrk(mcmics),wrk1(mcmics)
c      dimension wrk_12(mcmics),wrk1_12(mcmics)                          
c      dimension wrk_23(mcmics),wrk1_23(mcmics)                          
c      dimension wrk_13(mcmics),wrk1_13(mcmics)                          
c      dimension wrk_123(mcmics),wrk1_123(mcmics)                        
c      dimension wrk_132(mcmics),wrk1_132(mcmics)                        
c
      zero = 0.d0
c 
c     zero out Shepard variables
c
      do i=1,mcmics
        do j=1,mcmesp+2
          dqsw(i,j) =  0.d0
          dqsw_12(i,j) =  0.d0
          dqsw_23(i,j) =  0.d0
          dqsw_13(i,j) =  0.d0
          dqsw_123(i,j) =  0.d0
          dqsw_132(i,j) =  0.d0
        enddo
      enddo
c      do i=1,mcmesp+2
      do i=1,mcmesp
c        e12pnt(i) = 0.0d0
        e12pf(i) = 0.0d0
        e12p(i) = 0.0d0
c        e12pnt_12(i) = 0.0d0                                            
        e12pf_12(i) = 0.0d0                                             
        e12p_12(i) = 0.0d0                                              
c        e12pnt_23(i) = 0.0d0                                            
        e12pf_23(i) = 0.0d0                                             
        e12p_23(i) = 0.0d0                                              
c        e12pnt_13(i) = 0.0d0                                            
        e12pf_13(i) = 0.0d0                                             
        e12p_13(i) = 0.0d0                                              
c        e12pnt_123(i) = 0.0d0                                           
        e12pf_123(i) = 0.0d0                                            
        e12p_123(i) = 0.0d0                                             
c        e12pnt_132(i) = 0.0d0                                           
        e12pf_132(i) = 0.0d0                                            
        e12p_132(i) = 0.0d0                                             
      enddo       
       do i=1,mcmesp                                                    
        F(i)=0.0d0
        F_12(i)=0.0d0
        F_23(i)=0.0d0
        F_13(i)=0.0d0
        F_123(i)=0.0d0
        F_132(i)=0.0d0
        cat(i)=0.0d0
        cat_12(i)=0.0d0
        cat_23(i)=0.0d0
        cat_13(i)=0.0d0
        cat_123(i)=0.0d0
        cat_132(i)=0.0d0
        enddo     
        do i=1,mcmesp*6
        Fw(i)=0.d0
        enddo
c
       e12 = zero
       e12_12 = zero                                                    
       e12_23 = zero                                                    
       e12_13 = zero                                                    
       e12_123 = zero                                                   
       e12_132 = zero                                                   
             e12a= zero                                                 
             e12b= zero                                                 
             e12c= zero                                                 
             e12d= zero                                                 
             e12e= zero                                                 
             e12f= zero                                                 
c
c     calculate the displacement in internal coordinates used for
c     generalized distances
c
       do j=1,mcnesp+2
         do i=1,mcnics
          dqsw(i,j)=qd(i)-qs0(i,j)
          dqsw_12(i,j)=qd(i)-qs0_12(i,j)                                 
          dqsw_23(i,j)=qd(i)-qs0_23(i,j)                                 
          dqsw_13(i,j)=qd(i)-qs0_13(i,j)                                 
          dqsw_123(i,j)=qd(i)-qs0_123(i,j)                               
          dqsw_132(i,j)=qd(i)-qs0_132(i,j)                               
         enddo
         if (mcndas.gt.0) then
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas
               if (dqsw(i,j).lt.-fpi) then
                   dqsw(i,j) = dqsw(i,j)+2.0d0*fpi
               elseif (dqsw(i,j).gt.fpi) then
                   dqsw(i,j) = dqsw(i,j)-2.0d0*fpi
               endif
            enddo
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas                 
               if (dqsw_12(i,j).lt.-fpi) then                            
                   dqsw_12(i,j) = dqsw_12(i,j)+2.0d0*fpi                  
               elseif (dqsw_12(i,j).gt.fpi) then                         
                   dqsw_12(i,j) = dqsw_12(i,j)-2.0d0*fpi                  
               endif                                                    
            enddo                                                       
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas                 
               if (dqsw_23(i,j).lt.-fpi) then                            
                   dqsw_23(i,j) = dqsw_23(i,j)+2.0d0*fpi                  
               elseif (dqsw_23(i,j).gt.fpi) then                         
                   dqsw_23(i,j) = dqsw_23(i,j)-2.0d0*fpi                  
               endif                                                    
            enddo                                                       
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas                 
               if (dqsw_13(i,j).lt.-fpi) then                            
                   dqsw_13(i,j) = dqsw_13(i,j)+2.0d0*fpi                  
               elseif (dqsw_13(i,j).gt.fpi) then                         
                   dqsw_13(i,j) = dqsw_13(i,j)-2.0d0*fpi                  
               endif                                                    
            enddo                                                       
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas                 
               if (dqsw_123(i,j).lt.-fpi) then                           
                   dqsw_123(i,j) = dqsw_123(i,j)+2.0d0*fpi                
               elseif (dqsw_123(i,j).gt.fpi) then                        
                   dqsw_123(i,j) = dqsw_123(i,j)-2.0d0*fpi                
               endif                                                    
            enddo                                                       
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas                 
               if (dqsw_132(i,j).lt.-fpi) then                           
                   dqsw_132(i,j) = dqsw_132(i,j)+2.0d0*fpi                
               elseif (dqsw_132(i,j).gt.fpi) then                        
                   dqsw_132(i,j) = dqsw_132(i,j)-2.0d0*fpi                
               endif                                                    
            enddo                                                       
         endif
      enddo
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
      do mciesp=1,mcnesp
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
c          ctrm=0.d0
          qtrm=0.d0
          btrm_12=0.d0                                                  
          btrm_23=0.d0                                                  
          btrm_13=0.d0                                                  
          btrm_123=0.d0                                                 
          btrm_132=0.d0                                                 
c          ctrm_12=0.d0                                                  
c          ctrm_23=0.d0                                                  
c          ctrm_13=0.d0                                                  
c          ctrm_123=0.d0                                                 
c          ctrm_132=0.d0                                                 
          qtrm_12=0.d0                                                  
          be12=0.d0                                                     
          be12_12=0.d0                                                  
          be12_23=0.d0                                                  
          be12_13=0.d0                                                  
          be12_123=0.d0                                                 
          be12_132=0.d0                                                 
c
          do i=1,mcnics
c            wrk(i) =0.d0
c            wrk_12(i) =0.d0                                             
c            wrk_23(i) =0.d0                                             
c            wrk_13(i) =0.d0                                             
c            wrk_123(i) =0.d0                                            
c            wrk_132(i) =0.d0                                            
            btrm=btrm+bevbm(i,mciesp)*dqsw(i,mciesp)                     
            btrm_12=btrm_12+bevbm_12(i,mciesp)*dqsw_12(i,mciesp)          
            btrm_23=btrm_23+bevbm_23(i,mciesp)*dqsw_23(i,mciesp)         
            btrm_13=btrm_13+bevbm_13(i,mciesp)*dqsw_13(i,mciesp)         
            btrm_123=btrm_123+bevbm_123(i,mciesp)*dqsw_123(i,mciesp)     
            btrm_132=btrm_132+bevbm_132(i,mciesp)*dqsw_132(i,mciesp)     
c            do j=1,mcnics
c              wrk(i)=wrk(i)+dqsw(j,mciesp)*cevbm(i,j,mciesp)
c          wrk_12(i)=wrk_12(i)+dqsw_12(j,mciesp)*cevbm_12(i,j,mciesp)     
c          wrk_23(i)=wrk_23(i)+dqsw_23(j,mciesp)*cevbm_23(i,j,mciesp)     
c          wrk_13(i)=wrk_13(i)+dqsw_13(j,mciesp)*cevbm_13(i,j,mciesp)     
c          wrk_123(i)=wrk_123(i)+dqsw_123(j,mciesp)*cevbm_123(i,j,mciesp) 
c          wrk_132(i)=wrk_132(i)+dqsw_132(j,mciesp)*cevbm_132(i,j,mciesp) 
c            enddo
c            ctrm=ctrm+dqsw(i,mciesp)*wrk(i)
c            ctrm_12=ctrm_12+dqsw_12(i,mciesp)*wrk_12(i)                  
c            ctrm_23=ctrm_23+dqsw_23(i,mciesp)*wrk_23(i)                  
c            ctrm_13=ctrm_13+dqsw_13(i,mciesp)*wrk_13(i)                  
c            ctrm_123=ctrm_123+dqsw_123(i,mciesp)*wrk_123(i)              
c            ctrm_132=ctrm_132+dqsw_132(i,mciesp)*wrk_132(i)              
          enddo
c
c     Added to avoid negative values for V12**2 term, 4/14/99 by Y. Kim
c
cc          delta = 0.00000001d0
c            udelta = 0.00016d0
            udelta = 0.0000000256d0
            unn = 2.d0
          be12 = 1.d0+btrm
          be12_12 = 1.d0+btrm_12
          be12_23 = 1.d0+btrm_23
          be12_13 = 1.d0+btrm_13
          be12_123 = 1.d0+btrm_123
          be12_132 = 1.d0+btrm_132
          e12p(mciesp) = aevbm(mciesp)*be12
          e12p_12(mciesp) = aevbm(mciesp)*be12_12                       
          e12p_23(mciesp) = aevbm(mciesp)*be12_23                       
          e12p_13(mciesp) = aevbm(mciesp)*be12_13                       
          e12p_123(mciesp) = aevbm(mciesp)*be12_123                     
          e12p_132(mciesp) = aevbm(mciesp)*be12_132                     
c
        enddo
c          A=0.0006d0
           A=0.0004d0
c           A=1000.0006d0
          s=4.0d0
c          s=2.0d0
          do mciesp=1,mcnesp
          cat(mciesp)=abs(e12p(mciesp))-abs(aevbm(mciesp))
          F(mciesp)=1.d0/(1.d0+(cat(mciesp)/A)**s)
          cat_12(mciesp)=abs(e12p_12(mciesp))-abs(aevbm(mciesp))
          F_12(mciesp)=1.d0/(1.d0+(cat_12(mciesp)/A)**s)
          cat_23(mciesp)=abs(e12p_23(mciesp))-abs(aevbm(mciesp))
          F_23(mciesp)=1.d0/(1.d0+(cat_23(mciesp)/A)**s)
          cat_13(mciesp)=abs(e12p_13(mciesp))-abs(aevbm(mciesp))
          F_13(mciesp)=1.d0/(1.d0+(cat_13(mciesp)/A)**s)
          cat_123(mciesp)=abs(e12p_123(mciesp))-abs(aevbm(mciesp))
          F_123(mciesp)=1.d0/(1.d0+
     *    (cat_123(mciesp)/A)**s)
          cat_132(mciesp)=abs(e12p_132(mciesp))-abs(aevbm(mciesp))
          F_132(mciesp)=1.d0/(1.d0+
     *    (cat_132(mciesp)/A)**s)
c          write (*,*) "Fnew", F(mciesp),F_12(mciesp),F_23(mciesp),
c     &    F_13(mciesp),F_123(mciesp),F_132(mciesp)
c
        enddo
          do i=1,mcnesp
          Fw(i)=F(i)
          Fw(i+mcnesp)=F_12(i)
          Fw(i+mcnesp*2)=F_23(i)
          Fw(i+mcnesp*3)=F_13(i)
          Fw(i+mcnesp*4)=F_123(i)
          Fw(i+mcnesp*5)=F_132(i)
          enddo
c
      return                                                            
      end 
c>>>>                                                                    0527MH10
c***********************************************************************
c     mcishz
c***********************************************************************
c
      subroutine mcishz(mcizr,mcndiz,mcnanz,mcndaz,mcnadz,
     &                  mcidiz,mcianz,mcidaz,mciadz)
c
c     This subroutine specifies which internal coordinates the resonance
c     intelgral is independent of.
c
      implicit double precision (a-h, o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      dimension mcizr(mcmics)
      dimension mcidiz(2,mcmics),mcianz(3,mcmics)
      dimension mcidaz(4,mcmics),mciadz(3,mcmics)
c
      icz=0
c
c     bond
c
      if (mcndiz.ne.0) then
c
         do 100 iz=1,mcndiz
c
            do 110 is=1,mcndis
               if((mcidiz(1,iz).eq.mcidis(1,is)).and.
     &            (mcidiz(2,iz).eq.mcidis(2,is))) then
                  icz=icz+1
                  mcizr(icz)=is
                  goto 150
               end if
 110        continue
c
            write(fu6,9001) mcidiz(1,iz),
     &                      mcidiz(2,iz)
            stop 'mcishz 1'
c
 150        continue
c
 100     continue
c
      end if
c
c     angle
c
      if (mcnanz.ne.0) then
c
         do 200 iz=1,mcnanz
c
            do 210 is=1,mcnans
               if (mcianz(1,iz).eq.mcians(1,is)) then
               if (mcianz(2,iz).eq.mcians(2,is)) then
               if (mcianz(3,iz).eq.mcians(3,is)) then
                  icz=icz+1
                  mcizr(icz)=mcndis+is
                  goto 250
               end if
               end if
               end if
 210        continue
c
            write(fu6,9002) mcianz(1,iz),
     &                      mcianz(2,iz),
     &                      mcianz(3,iz)
            stop 'mcishz 2'
c
 250        continue
c
 200     continue
c
      end if
c
c     dihedral angle
c
      if (mcndaz.ne.0) then
c
         do 300 iz=1,mcndaz
c
            do 310 is=1,mcndas
               if (mcidaz(1,iz).eq.mcidas(1,is)) then
               if (mcidaz(2,iz).eq.mcidas(2,is)) then
               if (mcidaz(3,iz).eq.mcidas(3,is)) then
               if (mcidaz(4,iz).eq.mcidas(4,is)) then
                  icz=icz+1
                  mcizr(icz)=mcndis+mcnans+is
                  goto 350
               end if
               end if
               end if
               end if
 310        continue
c
            write(fu6,9003) mcidaz(1,iz),
     &                      mcidaz(2,iz),
     &                      mcidaz(3,iz),
     &                      mcidaz(4,iz)
            stop 'mcishz 3'
c
 350        continue
c
 300     continue
c
      end if
c
c     linear bend
c
      if (mcnadz.ne.0) then
c
         do 400 iz=1,mcnadz
c
            do 410 is=1,mcnads
               if (mciadz(1,iz).eq.mciads(1,is)) then
               if (mciadz(2,iz).eq.mciads(2,is)) then
               if (mciadz(3,iz).eq.mciads(3,is)) then
                  icz=icz+1
                  mcizr(icz)=mcndis+mcnans+mcndas+is
                  goto 450
               end if
               end if
               end if
 410        continue
c
            write(fu6,9004) mciadz(1,iz),
     &                      mciadz(2,iz),
     &                      mciadz(3,iz)
            stop 'mcishzh 4'
c
 450        continue
c
 400     continue
c
      end if
c
c$$$      write(*,*) 'mcndiz=',mcndiz
c$$$      write(*,*) 'mcnanz=',mcnanz
c$$$      write(*,*) 'mcnadz=',mcnadz
c$$$      write(*,*) 'mcndaz=',mcndaz
c$$$      write(*,*) 'mciczr',(mcizr(i),i=1,icz)
c
c
c
      return
c
 9001 format(3x,'Error: the internal coordinate of distance ',
     &       i3,'-',i3,' in ICSHZERO is not included in ICSHEPARD.')
 9002 format(3x,'Error: the internal coordinate of angle ',i3,'-',
     &       i3,'-',i3,' in ICSHZERO is not included in ICSHEPARD.')
 9003 format(3x,'Error: the internal coordinate of dihedral angle ',
     &       i3,'-',i3,'-',i3,'-',i3,' in ICSHZERO is not included ',
     &       'in ICSHEPARD.')
 9004 format(3x,'Error: the internal coordinate of digenerate angle ',
     &       i3,'=',i3,'=',i3,' in ICSHZERO is not included ',
     &       'in ICSHEPARD.')
c
      end
c
c***********************************************************************
c     mcv12z
c***********************************************************************
c
      subroutine mcv12z
c
c     This subroutine sets the coefficients of Taylor expansion with 
c     respect to internal coordinates specified in ICSZERO to be zero
c     in the (EE-)MCSI calculation.
c
      implicit double precision (a-h, o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      include 'eemcmm.inc'
c
      data zero /0.0d+00/
c
      do 1000 isp=1,mcnesp
c
c
c     ICSHZERO
c
         do 100 iz=1,mcnzrh(isp)
c
            icz=mcizrh(iz,isp)
c
            do 200 ic=1,mcnics
               cevbm(icz,ic,isp)=zero
               cevbm(ic,icz,isp)=zero
 200        continue
c
            if(mciee.eq.1) then
               do 300 in=1,mcnatm
                  ceerv(icz,in,isp)=zero
 300           continue
            end if
c
 100     continue
c
c     ICSAZERO
c
         do 110 iz=1,mcnzra(isp)
c
            icz=mcizra(iz,isp)
            bevbm(icz,isp)=zero
c
            do 210 ic=1,mcnics
               cevbm(icz,ic,isp)=zero
               cevbm(ic,icz,isp)=zero
 210        continue
c
            if(mciee.eq.1) then
               do 310 in=1,mcnatm
                  ceerv(icz,in,isp)=zero
 310           continue
            end if
c
 110     continue
c
c     ICSCZERO
c
         do 120 iz=1,mcnzrc(isp)
c
            icz=mcizrc(iz,isp)
c
            do 220 ic=1,mcnics
               if(ic.eq.icz) goto 220
               cevbm(icz,ic,isp)=zero
               cevbm(ic,icz,isp)=zero
 220        continue
c
            if(mciee.eq.1) then
               do 320 in=1,mcnatm
                  ceerv(icz,in,isp)=zero
 320           continue
            end if
c
 120     continue
c
 1000 continue
c
      return
      end
c
c***********************************************************************
c     mcprcf
c***********************************************************************
c
      subroutine mcprcf
c
c     This subroutine prints the coefficients of Taylor expansion.
c
      implicit double precision (a-h, o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      include 'eemcmm.inc'
c
      dimension ptmp(mcmics)
c
c
      do 1000 i=1,mcnesp
c
         write(fu6,9999) i
         write(fu6,9998) aevbm(i)
c
         if (mcndis.ne.0) then
            do 100 j=1,mcndis
               write(fu6,9997) j,mcidis(1,j),mcidis(2,j),bevbm(j,i)
 100        continue
         end if
         if (mcnans.ne.0) then
            do 110 j=1,mcnans
               write(fu6,9996) j+mcndis,mcians(1,j),mcians(2,j),
     *                         mcians(3,j),bevbm(j+mcndis,i)
 110        continue
         end if
         if (mcndas.ne.0) then
            do 120 j=1,mcndas
               write(fu6,9995) j+mcndis+mcnans,mcidas(1,j),
     *                         mcidas(2,j),mcidas(3,j),
     *                         mcidas(4,j),bevbm(j+mcndis+mcnans,i)
 120        continue
         end if
         if (mcnads.ne.0) then
            do 130 j=1,mcnads
               write(fu6,9994) j+mcndis+mcnans+mcndas,
     *                         mciads(1,j),mciads(2,j),mciads(3,j),
     *                         bevbm(j+mcndis+mcnans+mcnads,i)
 130        continue
         end if
c
c
         if (mciee.ne.0) then
            write(fu6,*)
            do 200 j=1,mcnatm
               write(fu6,9993) j,bee(j,i)
 200        continue
         end if
c
         if (mcihfr.eq.0) goto 350
c
         if (mcndis.ne.0) then
            do 300 j=1,mcndis
               write(fu6,*)
               write(fu6,9992) j,mcidis(1,j),mcidis(2,j)
               do 301 k=1,mcnics
                  ptmp(k)=cevbm(k,j,i)
 301           continue
               call mcpgst(fu6,ptmp,mcnics,mcmics)
 300        continue
         end if
c
         if (mcnans.ne.0) then
            do 310 j=1,mcnans
               write(fu6,*)
               write(fu6,9991) j+mcndis,mcians(1,j),mcians(2,j),
     *                         mcians(3,j)
               do 311 k=1,mcnics
                  ptmp(k)=cevbm(k,j+mcndis,i)
 311           continue
               call mcpgst(fu6,ptmp,mcnics,mcmics)
 310        continue
         end if
c
         if (mcndas.ne.0) then
            do 320 j=1,mcndas
               write(fu6,*)
               write(fu6,9990) j+mcndis+mcnans,mcidas(1,j),
     *                         mcidas(2,j),mcidas(3,j),mcidas(4,j)
               do 321 k=1,mcnics
                  ptmp(k)=cevbm(k,j+mcndis+mcnans,i)
 321           continue
               call mcpgst(fu6,ptmp,mcnics,mcmics)
 320        continue
         end if
c
         if (mcnads.ne.0) then
            do 330 j=1,mcnads
               write(fu6,*)
               write(fu6,9989) j+mcndis+mcnans+mcndas,
     *                         mciads(1,j),mciads(2,j),mciads(3,j)
               do 331 k=1,mcnics
                  ptmp(k)=cevbm(k,j+mcndis+mcnans+mcndas,i)
 331           continue
               call mcpgst(fu6,ptmp,mcnics,mcmics)
 330        continue
         end if
c
 350     continue
c
         if (mciee.ne.0) then
c
           if(mcifqv.ne.0) then
c
              do 400 j=1,mcnatm
                 write(fu6,*)
                 write(fu6,9988) j
                 do 401 k=1,mcnatm
                    ptmp(k)=ceevv(k,j,i)
 401             continue
                 call mcpgst(fu6,ptmp,mcnatm,mcmatm)
 400          continue
c
           end if
c
           if(mcifqr.ne.0) then
c
              do 500 j=1,mcnatm
                 write(fu6,*)
                 write(fu6,9987) j
                 do 501 k=1,mcnics
                    ptmp(k)=ceerv(k,j,i)
 501             continue
                 call mcpgst(fu6,ptmp,mcnics,mcmics)
 500          continue
c
           end if
c
         end if
c

c
 1000 continue
c
c
c
      return
c
 9999 format(/1x,14('*'),2x,'Electronic structure ',
     *       'theory Shepard point ',i4,2x,15('*'))
 9998 format(/2x,'D(k) = ',f11.7,/)
 9997 format(2x,'bq(k) for (',i3,')     Distance     between ',
     *           i4,1x,i4,11x,': ',f11.7,' a.u.')
 9996 format(2x,'bq(k) for (',i3,')      Angle       between ',
     *           i4,1x,i4,1x,i4,6x,': ',f11.7,' a.u.')
 9995 format(2x,'bq(k) for (',i3,')  Dihedral angle  between ',
     *           i4,1x,i4,1x,i4,1x,i4,1x,': ',f11.7,' a.u.')
 9994 format(2x,'bq(k) for (',i3,') Degenerate angle between ',
     *           i4,1x,i4,1x,i4,6x,': ',f11.7,' a.u.')
 9993 format(2x,'bphi(k) for Atom ',i3,' : ',f11.7,' a.u.')
 9992 format(2x,'cqq(k) for (',i3,')     Distance     between ',
     *           i4,1x,i4,11x)
 9991 format(2x,'cqq(k) for (',i3,')      Angle       between ',
     *           i4,1x,i4,1x,i4,6x)
 9990 format(2x,'cqq(k) for (',i3,')  Dihedral angle  between ',
     *           i4,1x,i4,1x,i4,1x,i4,1x)
 9989 format(2x,'cqq(k) for (',i3,') Degenerate angle between ',
     *           i4,1x,i4,1x,i4,6x)
 9988 format(2x,'cphiphi(k) for Atom ',i3)
 9987 format(2x,'cqphi(k) for Atom ',i3)
c
      end
c<<<<                                                                    0527MH10
