c
c******************************************************************************
c  NEBHHK
c******************************************************************************
c
      subroutine nebhhk(nebinp, ndim, nimg, ximg, gimg, himg, constant)   
c
c     Subroutine nebhhk
c
c     Created:  July 16, 1999 by J. M. Rodgers
c     Revised:  January 12, 2000 by P. L. Fast
c     Purpose:  
c          set the initial Hessian used by NEB as the block diagonal electronic
c          structure Hessian from low level. Although this guess does not include
c          the effect of spring potential, it should be much better than scaled unit
c          matrix
c
c     Called by:  newt
c     Calls:  hfmohhk, mcohhk, mnmhhk, muthhk, mcshhk, ibhhk, sachhk,
c             g2hhk, mg2hhk, g3hhk, mg3hhk, mqchhk, mcomp2hhk,          0710PJ00
c             imohchhk, proghhk, mccohhk, mc3bbhhk
c
c     Variables defined here:  none.
c  
      use files, only : outfile
      use optimize, only : ener, grad, hess
      use input, only : cartgeom, nebopt, mlinp
      use energy
      use gradient
      use hessian
      use param, only : pmco, pmnm, pmut, pib, psac, pmcs,
     *       lowhs, uniths
      use caltyp, only : thess
c
      implicit none
c
      integer ii, jj, k, ndim, nimg
      type (cartgeom) :: ximg(0:nimg+1)
      double precision, dimension(:), allocatable :: vimg,gimg1   
      double precision vimga, vimgb, vimgc
      double precision gimg(ndim)
      double precision himg(ndim,ndim)
      integer constant(*)
      type (nebopt)   :: nebinp

      double precision dum
      double precision, dimension(:), allocatable :: dum2
      integer  n3tm, natoms, ierr, i, j
      double precision r2, sum, x2a, x1a, x0a, x2b, x1b, x0b,   
     &                 x2c, x1c, x0c
      integer a,b,c,ia,ib,ic 

      natoms = mlinp%geom%natoms
      n3tm = 3*natoms

      allocate(dum2(n3tm))
      allocate(vimg(0:nimg+1), gimg1(ndim))
c
c Unit Hessian scaled by hscale
c
      if (mlinp%htyp.eq.uniths) then
         do 21 i=1, ndim
            do 22 j=1, ndim
               himg(i,j) = 0.0d0
  22        continue
            himg(i,i) = mlinp%hscale
  21     continue
c
c do a small dispacement to approximate the diagonal elements like MOPAC does
c
         k = 0 
         do i = 1, nimg
            do j = 1, n3tm
                k = k + 1
                ximg(i)%aucoord(j) = ximg(i)%aucoord(j) 
     &                               + 0.01*sign(1.0d0,gimg(k))
                ximg(i)%angcoord(j) = ximg(i)%aucoord(j)*0.52918d0
            end do
         end do 
         call nebghk(nebinp,ximg,vimg,gimg1)
         do k = 1, ndim
            himg(k,k) = (gimg1(k) - gimg(k))/
     &                  (0.01d0*sign(1.0d0,gimg(k)))             
            if (himg(k,k) .lt. 0.0d0) then
                himg(k,k) = abs(gimg(i))/0.06d0
            end if 
         end do
         k = 0
         do i = 1, nimg
            do j = 1, n3tm
                k = k + 1
                ximg(i)%aucoord(j) = ximg(i)%aucoord(j) 
     &                               - 0.01*sign(1.0d0,gimg(k))
                ximg(i)%angcoord(j) = ximg(i)%aucoord(j)*0.52918d0
            end do
         end do

c
c Low level Hessian - make sure that not set energy and gradient to low
c   level values as well.
c
      elseif (mlinp%htyp.eq.lowhs) then
         do k = 1, nimg       
            mlinp%geom%angcoord(:n3tm) = ximg(k)%angcoord(:n3tm)
            mlinp%geom%aucoord(:n3tm) = ximg(k)%angcoord(:n3tm)
     &                                  /0.52918d0

            call proghhk(mlinp%progrms%hessprog,mlinp%hmeth,mlinp%hbas,               
     *                   mlinp%geom, mlinp%toptl, dum, dum2,
     *                   hess(:n3tm,:n3tm), ierr)
c           call lowdisp( mlinp%geom%natoms )

         
            do i = 1, n3tm
               do j = 1, n3tm  
                   himg((k-1)*n3tm+i,(k-1)*n3tm+j) = hess(i,j)
               end do
            end do
         end do
c
c Otherwise will be doing a high level Hessian from numerical
c differentiations (one-direction), unless analytical Hessian
c is formulated for the original NEB algorithm (BISECT NEB)(nebalg = 4 ) 
c 
      else

       if (nebinp%nebalg .ne. 4) then

c
c set to diagnal first
c
         do i=1, ndim
            do j=1, ndim
               himg(i,j) = 0.0d0
            end do
            himg(i,i) = mlinp%hscale
         end do 
                
         do i = 1, nimg
            do j = 1, n3tm

              if (constant(j).eq.0) then

                ximg(i)%aucoord(j) = ximg(i)%aucoord(j) + 0.005
                ximg(i)%angcoord(j) = ximg(i)%aucoord(j)*0.52918d0

c
c --- calculate all Hessian elements
c               call nebghk(nebinp,ximg,vimg,gimg1)
c               do k = 1, ndim
c                  himg((i-1)*n3tm+j,k) = (gimg1(k) - gimg(k))/0.005 
c               end do
c

c
c --- only calculate non-zero elements. A shorter version the NEB
c     force routine is used (nebgst) to only calculate the force 
c     associated with non-zero Hessian elements for each image.
c
                call nebgst(nebinp,ximg,vimg,gimg1, i)
                do ii = max(1,i-1), min(nimg,i+1)
                    do jj = 1, n3tm
                       k = (ii-1)*n3tm+jj
                       himg((i-1)*n3tm+j,k) = (gimg1(k) - gimg(k))/0.005 
c
c debug Hessian elements
c
c                      write(*,*) 'HIMG(',(i-1)*n3tm+j,',',k,')=', 
c    &                             himg((i-1)*n3tm+j,k)  
c
                    end do  
                end do

                ximg(i)%aucoord(j) = ximg(i)%aucoord(j) - 0.005
                ximg(i)%angcoord(j) = ximg(i)%aucoord(j)*0.52918d0
  
              endif

            end do
         end do

c for the original NEB method (BISECT-NEB), we tried to formulate the Hessian 
c analytically (nebalg = 4).  
c        H = dG/dx = d(G_per - F_spr)/dx  

       else 

         write (outfile,*) 'NEB Hessian is calculated analytically: ' 
c
c set to zero first
c
         do i=1, ndim
            do j=1, ndim
               himg(i,j) = 0.0d0
            end do
         end do
c
c first we calculate the block diagnal Hessian for the spring force 
c (dF_spr_Ri/dRi) based on:
c   F_spr = k[(Ri+1 - Ri) - (Ri-Ri-1)].tau^2 
c   tau = (Ri+1 - Ri-1)/|Ri+1 - Ri-1|
c
c therefore (a,b are carteisan coordinate, and i is number of image)
c   H_spr(ab,i) = 2[xa^(i+1)-xa^(i-1)][xb^(i+1)-xb^(i-1)]/|Ri+1 - Ri-1|^2
c  --- OK ---
         do i = 1, nebinp%nimg 
            r2 = 0.0d0
            do a = 1, n3tm
               x2a = ximg(i+1)%aucoord(a)
               x0a = ximg(i-1)%aucoord(a)
               r2 = r2 + (x2a-x0a)*(x2a-x0a)
            end do
            do a = 1, n3tm
               x2a = ximg(i+1)%aucoord(a)
               x0a = ximg(i-1)%aucoord(a)
               ia = (i-1)*n3tm+a
               do b = 1 ,n3tm
                   x2b = ximg(i+1)%aucoord(b)
                   x0b = ximg(i-1)%aucoord(b)
                   ib = (i-1)*n3tm+b
                   himg(ia,ib) = himg(ia,ib) + nebinp%kspr * 
     &                             2.0d0*(x2b-x0b)*(x2a-x0a) / r2
c
c debug Hessian elements
c
c                   write(*,*) 'H_spr(',ia,',',ib,')=',
c     &                         himg(ia,ib)

               end do
            end do
         end do
c
c next we calculate the block diagnal Hessian for the spring force
c (dF_spr_Ri/dRj), we only calculate the upper triangle where j>i,
c and assigh j<i elements by symmetry
c --- OK ---
c
 299     continue
         do i = 1, nebinp%nimg
           if (i .lt. nebinp%nimg) then
            r2 = 0.0d0
            sum = 0.0d0
            do a = 1, n3tm
               x2a = ximg(i+1)%aucoord(a)
               x1a = ximg(i)%aucoord(a)
               x0a = ximg(i-1)%aucoord(a)
               r2 = r2 + (x2a - x0a)*(x2a - x0a)
               sum = sum + (x2a - 2.0d0*x1a + x0a) * (x2a - x0a)   
            end do
            do a = 1, n3tm
               x2a = ximg(i+1)%aucoord(a)
               x1a = ximg(i)%aucoord(a)
               x0a = ximg(i-1)%aucoord(a)
               ia = (i-1)*n3tm+a
               do b = 1 ,n3tm
                  x2b = ximg(i+1)%aucoord(b)
                  x1b = ximg(i)%aucoord(b)
                  x0b = ximg(i-1)%aucoord(b)
                  ib = i*n3tm+b
                  himg(ia,ib) = himg(ia,ib) + nebinp%kspr *
     &                       ( -2.0d0*(x2b-x1b)*(x2a-x0a)/r2 + 
     &                          2.0*sum*(x2a-x0a)*(x2b-x0b)/r2**2.0)   
                  if (a .eq. b) then
                      himg(ia,ib) = himg(ia,ib) - nebinp%kspr*sum/r2
                  end if
                  himg(ib,ia) = himg(ia,ib)
c
c debug Hessian elements
c
c                   write(*,*) 'H_spr(',ia,',',ib,')=',
c     &                         himg(ia,ib)

               end do
            end do
           end if    
         end do
c        
c Finally, we calculate the gradient of the projection term
c      dG_per/dx = dG(1-tau^2)/dx = H (1-tau^2) + Gd(1-tau^2)/dx
c                = H - H.tau^2+G.tau(dtau/dx)
c                 (I)   (II)      (III)

c
c term (I) + (II): dG/dx - H.tau^2, block diagnal term only, since
c the true Hessian does not have any term coupling images.
c --- OK ---
c
 399     continue 
         do i = 1, nebinp%nimg
             r2 = 0.0d0
             do a = 1, n3tm
               x2a = ximg(i+1)%aucoord(a)
               x0a = ximg(i-1)%aucoord(a)
               r2 = r2 + (x2a-x0a)*(x2a-x0a)
             end do

             mlinp%geom%angcoord(:n3tm) = ximg(i)%angcoord(:n3tm)
             mlinp%geom%aucoord(:n3tm) = ximg(i)%angcoord(:n3tm)
     &                                  /0.52918d0
             call opthhk

             do a = 1, n3tm
                ia = (i-1)*n3tm+a
                x2a = ximg(i+1)%aucoord(a)
                x0a = ximg(i-1)%aucoord(a)
                do b = 1, n3tm
                    ib = (i-1)*n3tm+b
                    x2b = ximg(i+1)%aucoord(b)
                    x0b = ximg(i-1)%aucoord(b)

                    sum = 0.0d0
                    do c = 1, n3tm 
                       x2c = ximg(i+1)%aucoord(c)
                       x0c = ximg(i-1)%aucoord(c)
                       sum = sum + hess(c,b)*(x2c-x0c)
                    end do

                    himg(ia,ib) = himg(ia,ib) + hess(a,b)
     &                              - sum*(x2a-x0a)/r2

c
c debug Hessian elements
c
c                   write(*,*) 'H_tt(',ia,',',ib,')=',
c     &                         himg(ia,ib)

                end do
             end do
         end do
c
c term (III): -G.(dtau)/dx.tau - G.tau(dtau/dx), no block diagnal term,
c since tau is only determined by Ri+1 and Ri-1 therefore tau only has
c coupling term between adjacent images
c --- OK ---
c
 499     continue
         do i = 1, nebinp%nimg
           if (i .lt. nebinp%nimg) then
             r2 = 0.0d0
             do a = 1, n3tm
               x2a = ximg(i+1)%aucoord(a)
               x0a = ximg(i-1)%aucoord(a)
               r2 = r2 + (x2a-x0a)*(x2a-x0a)
             end do

             do a = 1, n3tm
                ia = (i-1)*n3tm+a
                x2a = ximg(i+1)%aucoord(a)
                x0a = ximg(i-1)%aucoord(a)

                do b = 1, n3tm
                    ib = i*n3tm+b
                    x2b = ximg(i+1)%aucoord(b)
                    x0b = ximg(i-1)%aucoord(b)

                    sum = 0.0d0
                    do c = 1, n3tm
                       ic = (i-1)*n3tm+c
                       x2c = ximg(i+1)%aucoord(c)
                       x0c = ximg(i-1)%aucoord(c)
                       sum = sum + gimg(ic)*(x2c-x0c)
                    end do
                    himg(ia,ib) = himg(ia,ib) - 
     &                       gimg(ib)*(x2a-x0a)/r2 +
     &                       sum*(x2a-x0a)*2.0d0*(x2b-x0b)/(r2**2.0)          

                    if (a .eq. b) then
                        himg(ia,ib) = himg(ia,ib) - sum/r2 
                    end if

                    himg(ib,ia) = himg(ia,ib)

c
c debug Hessian elements
c            
c                   write(*,*) 'G_d(tt)(',ia,',',ib,')=',
c     &                         himg(ia,ib)


                end do
             end do
           end if 
         end do

 699   continue

       endif

      end if

      return 
      end

c***************************************************************
c NEBGST
c***************************************************************
      subroutine nebgst(nebinp, ximg, vimg, gimg, ithimg)
c
c     Created:  July, 2004 by Nuria Gonzalez-Garcia
c     Purpose:  Driver for the nudged elastic band (NEB) method
c
c     Description:
c         The driver to calcualte the NEB total force only for 
c         adjacent images. This will be useful for numerically
c         calculation of Hessians, which only contains non-zero
c         blocks for adjacent images.
c
c     Called by:
c     Calls:
c
      use files, only : outfile
      use input, only : cartgeom, nebopt
      use optimize, only : ener, grad
      use input, only : mlinp
c
      implicit none
c   
      integer ithimg
      type (nebopt) :: nebinp
      type (cartgeom) :: ximg(0:nebinp%nimg+1)
      double precision gimg(3*nebinp%rgeom%natoms,nebinp%nimg)
      double precision vimg(0:nebinp%nimg+1)
      double precision, dimension(:,:), allocatable :: tfimg
      double precision, dimension(:,:), allocatable :: timg
      double precision, dimension(:), allocatable :: tau, tfor
      double precision, dimension(:), allocatable :: ximga, ximgb, ximgc
      double precision vimga, vimgb, vimgc
c
c number of angstroms in a bohr (au)
c

      double precision angtoau
c
      integer i,j,k,n3tm                                               
c
      n3tm = 3*nebinp%rgeom%natoms
c
      angtoau = 0.5291772083d0
c
      allocate (tfimg(n3tm,0:nebinp%nimg+1))
      allocate (timg(n3tm,0:nebinp%nimg+1))
      allocate (tau(n3tm),tfor(n3tm))
      allocate (ximga(n3tm),ximgb(n3tm),ximgc(n3tm))
c
c calculate gradient for adjacent images
c
      do j = ithimg - 1, ithimg + 1
          mlinp%geom%angcoord(:n3tm) = ximg(j)%angcoord(:n3tm)
          mlinp%geom%aucoord(:n3tm) = ximg(j)%angcoord(:n3tm)
     &                                /0.52918d0
          if (j .eq. 0 .or. j .eq. nebinp%nimg+1) then
             call optehk
             vimg(j) = ener
          else
             call optghk
             vimg(j) = ener
             gimg(:n3tm,j) = grad(:n3tm)
          endif
      end do
c
c debug energy
c
c      do j = ithimg - 1, ithimg + 1
c         write(outfile,*) 'VIMG (',j,')=', vimg(j)
c      end do
c
c      
      do j = max(1, ithimg-1), min(nebinp%nimg, ithimg+1)
c
c tangent calculation:
c
c         ximgb(:n3tm)=ximg(j)%angcoord(:n3tm)
c         ximga(:n3tm)=ximg(j-1)%angcoord(:n3tm)
c         ximgc(:n3tm)=ximg(j+1)%angcoord(:n3tm)
c
c keep all NEB calculations in atomic unit for consistency, although    1026PJ04
c it c won't affect the tagent calcuations, the unit does have some     1026PJ04
c effect on spring force                                                1026PJ04
          ximgb(:n3tm)=ximg(j)%aucoord(:n3tm)                           1026PJ04
          ximga(:n3tm)=ximg(j-1)%aucoord(:n3tm)                         1026PJ04
          ximgc(:n3tm)=ximg(j+1)%aucoord(:n3tm)                         1026PJ04

          vimgb=vimg(j)
          vimga=vimg(j-1)
          vimgc=vimg(j+1)
          call tangcalc(ximga, ximgb, ximgc,
     &                  vimga, vimgb, vimgc,
     &                  nebinp%rgeom%natoms, n3tm, tau, 
     &                  nebinp%nebalg)    
          timg(:n3tm,j) = tau(:n3tm)
c
c debug tangent: Information that can be printed out if required by the user
c
c          write(outfile,*) 'Tangent for Image ',j,':'
c          do k = 1, n3tm
c              write(outfile,1055) tau(k)
c          end do
c1055  format(t20,d15.8,t40,d15.8,t60,d15.8)

c
c Calculation of total force: Fspr + Ftrue
c We store the total gradient (negtive force) in gimg and
c return them to the minimizer NEBMIN
c
          call forcalc(nebinp%kspr, ximga, ximgb, ximgc,      
     &                 gimg(:,j), tau, tfor, n3tm, nebinp%nebalg)    

          tfimg(:n3tm,j) = tfor(:n3tm)
          gimg(:n3tm,j) = - tfor(:n3tm)
c
c debug total force: Information that can be printed out if required by the user
c
c          write(outfile,*) ' Total force for Image ', j,':'
c          do k = 1, n3tm
c              write(outfile ,1055) tfor(k)
c          end do

      end do
c
      return
      end

c***************************************************************
c NEBGHK
c***************************************************************
      subroutine nebghk(nebinp, ximg, vimg, gimg,niter)
c
c     Created:  July, 2004 by Nuria Gonzalez-Garcia
c     Purpose:  Driver for the nudged elastic band (NEB) method
c
c     Description:
c         The driver to calculate the NEB total force.
c         The current version of NEB implementing the tangent and
c         spring forces described in Jonsson et al. J Chem Phys
c         113(22), 9978 (2000)
c
c     Called by:
c     Calls:
c
      use files, only : outfile
      use input, only : cartgeom, nebopt
      use optimize, only : ener, grad
      use input, only : mlinp
c
      implicit none
c    
      type (nebopt) :: nebinp 
      type (cartgeom) :: ximg(0:nebinp%nimg+1)
      double precision gimg(3*nebinp%rgeom%natoms,nebinp%nimg)     
      double precision vimg(0:nebinp%nimg+1)
      double precision, dimension(:,:), allocatable :: tfimg
      double precision, dimension(:,:), allocatable :: timg  
      double precision, dimension(:), allocatable :: tau, tfor
      double precision, dimension(:), allocatable :: ximga, ximgb, ximgc   
      double precision vimga, vimgb, vimgc
c
c number of angstroms in a bohr (au)
c
      double precision angtoau
c
c Variables added while implementing the CI-NEB                         0622NG05
c
      double precision maxener                                          0622NG05
      integer maximg                                                    0622NG05
      integer niter                                                     0623NG05
c
      integer i,j,k,n3tm
      n3tm = 3*nebinp%rgeom%natoms
c
      angtoau = 0.5291772083d0
c
      allocate (tfimg(n3tm,0:nebinp%nimg+1))
      allocate (timg(n3tm,0:nebinp%nimg+1))
      allocate (tau(n3tm),tfor(n3tm))
      allocate (ximga(n3tm),ximgb(n3tm),ximgc(n3tm))
c
c calculate gradient for all images
c
      do j = 0, nebinp%nimg + 1
          mlinp%geom%angcoord(:n3tm) = ximg(j)%angcoord(:n3tm)
          mlinp%geom%aucoord(:n3tm) = ximg(j)%angcoord(:n3tm)       
     &                                /angtoau
          if (j .eq. 0 .or. j .eq. nebinp%nimg+1) then
             call optehk
             vimg(j) = ener
          else
             call optghk
             vimg(j) = ener
             gimg(:n3tm,j) = grad(:n3tm)
          endif 
      end do
c
c debug energy

      write(outfile,1022) niter                                         0208NG06
      do j = 0, nebinp%nimg + 1                                         0208NG06
         write(outfile,1024) j, vimg(j)                                 0208NG06
      end do                                                            0208NG06
1022  format(/1x,45('-'),/2x,'SUMMARY OF IMAGE ENERGIES AT ITERATION: ' 0208NG06
     &       ,i3,/2x,45('-')/)                                          0208NG06
1024  format(2x,'Vimg (',i3,')=',2x,f19.12)                             0720BE06
c
c It should be important to debut the highest energy image              0621NG05
c
      maxener=vimg(1)                                                   0621NG05
      maximg=1                                                          0621NG05
c
      do i = 2,nebinp%nimg                                              0621NG05
          if (vimg(i).gt.maxener) then                                  0621NG05
             maxener=vimg(i)                                            0621NG05
             maximg=i                                                   0621NG05
          end if                                                        0621NG05
      end do
c
c Print the highest energy image and enery                              0621NG05
c        
         write (outfile,1025) maximg                                    0621NG05
         write (outfile,1026) maxener                                   0621NG05
c
1025  format(/3x,'Highest Energy image is: ',i3)                        0208NG06
1026  format(/3x,'Highest Energy image energy is: ',f19.12)             0208NG06
c
c LOOP OVER THE NUMBER OF IMAGES TO OBTAIN ALL THE INFO
c
c 1. Tangent calculation
c
      do j = 1, nebinp%nimg
c
c keep all NEB calculations in atomic unit for consistency, although    1026PJ04
c it c won't affect the tagent calcuations, the unit does have some     1026PJ04 
c effect on spring force                                                1026PJ04
          ximgb(:n3tm)=ximg(j)%aucoord(:n3tm)                           1026PJ04
          ximga(:n3tm)=ximg(j-1)%aucoord(:n3tm)                         1026PJ04
          ximgc(:n3tm)=ximg(j+1)%aucoord(:n3tm)                         1026PJ04

          vimgb=vimg(j)
          vimga=vimg(j-1)
          vimgc=vimg(j+1)
          call tangcalc(ximga, ximgb, ximgc, 
     &                  vimga, vimgb, vimgc,
     &                  nebinp%rgeom%natoms, n3tm, tau,
     &                  nebinp%nebalg)
          timg(:n3tm,j) = tau(:n3tm)
c
c debug tangent
c
c          write(outfile,*) 'Tangent for Image ',j,':' 
c          do k = 1, n3tm
c              write(outfile,1055) tau(k)
c          end do
c1055  format(t20,d15.8,t40,d15.8,t60,d15.8)

c
c 2. Calculation of total force: Fspr + Ftrue
c
c We store the total gradient (negtive force) in gimg and
c return them to the minimizer NEBMIN
c
          call forcalc(nebinp%kspr, ximga, ximgb, ximgc,
     &                 gimg(:,j), tau, tfor, n3tm, nebinp%nebalg,
     &                 maximg,j,niter)                                  0622NG05
              
          tfimg(:n3tm,j) = tfor(:n3tm)
          gimg(:n3tm,j) = - tfor(:n3tm)
c
c debug total force
c
c          write(outfile,*) ' Total force for Image ', j,':' 
c          do k = 1, n3tm
c              write(outfile ,1055) tfor(k)
c          end do

      end do 
c
      return
      end
c
c***********************************************************************
c REORIENT
c***********************************************************************
      subroutine reorient(xx1, xx2, natoms, n3tm, atmmss)
C
c     Created:  July, 2004 by Nuria Gonzalez-Garcia
c     Purpose:  align product to reactant before interpolation
c     Description:
c         this routine is derived from POLYRATE routine 'calcs' which
c         reorients xx2 with respect to xx1 following the algorithm
c         proposed by Chen Theor. Chim. Acta 1989,75,481
c     Input:
c        -xx1 and xx2 are the reference and the final geometries,
c         respectively
c     Called by:
c               neb
c     Calls:
c               center, lin, ssx
c
      use files, only : outfile
c
      implicit double precision (a-h,o-z)
c
      integer natoms, n3tm
      double precision xx1(n3tm),xx2(n3tm), xscr(n3tm),
     &                 xx2s(n3tm),xx2b(n3tm),atmmss(natoms)
      double precision a(3,3),b(3),y(3),scr(3,4)
      double precision rota(3,3), rotas(3,3), tmprot(3,3)
      double precision x(n3tm),amass(n3tm)
      double precision sval, det
c
      data tol /1.d-5/
      data nfrac /20/
      data shft /0.2D0/
c
c     get atomic mass for each coordinate
c
      do i = 1, natoms
         do j = 1, 3
             amass((i-1)*3+j) = atmmss(i)
         enddo
      enddo
C
C     the center of mass of the points is placed on the origin of coordinates
C
      ipp=1
      nend=n3tm

      dist=ssx(xx1,xx2,amass,nend)

      do 10 i=1,nend
         x(i)=xx1(i)
 10   continue
      call center (natoms,n3tm,amass,x)
      do 15 i=1,nend
         xx1(i)=x(i)
 15   continue
      do 20 i=1,nend
         x(i)=xx2(i)
 20   continue
      call center (natoms,n3tm,amass,x)
      do 30 i=1,nend
         xx2(i)=x(i)
         xx2s(i)=x(i)
         xx2b(i)=x(i)
 30   continue
c
      gdist=ssx(xx1,xx2,amass,nend)
c
c Initialize rotation matrix
c
      do i=1,3
        do j=1,3
          rotas(i,j)=0.d0
        enddo
      enddo
      do i=1,3
          rotas(i,i)=1.d0
      enddo
c
c rotate the molecule in order to get the best initial orientation
c
      alp=0.d0
      bet=0.d0
      gam=0.d0
      do 42 icosal=1,nfrac
         do 44 icosbet=1,nfrac
            do 46 icosgam=1,nfrac
c
c construct the rotation matrix (Euler)
c
               alp=2.d0*pi/dble(nfrac)*dble(icosal-1)
               bet=2.d0*pi/dble(nfrac)*dble(icosbet-1)
               gam=2.d0*pi/dble(nfrac)*dble(icosgam-1)

               cal=cos(alp)
               cbe=cos(bet)
               cga=cos(gam)

               sal=sin(alp)
               sbe=sin(bet)
               sga=sin(gam)

               rota(1,1) =  cal*cga - cbe*sga*sal
               rota(1,2) =  cal*sga + cbe*cga*sal
               rota(1,3) =  sal*sbe

               rota(2,1) = -sal*cga - cbe*sga*cal
               rota(2,2) = -sal*sga + cbe*cga*cal
               rota(2,3) =  cal*sbe

               rota(3,1) =  sbe*sga
               rota(3,2) = -sbe*cga
               rota(3,3) =  cbe

c rotate coordinates xx2
c
               do i=1,3*natoms
                  xscr(i)=xx2s(i)
               end do

               do i=1,natoms
                  do j=1,3
                     sum =0.0d0
                     do k=1,3
                        idum = 3*(i-1)+k
                        sum = sum + rota(j,k)*xscr(idum)
                     end do
                     idum = 3*(i-1)+j
                     xx2(idum)=sum
                  end do
               enddo

               do i=1,3*natoms
                  x(i)=xx2(i)
               end do
               call center (natoms,n3tm,amass,x)
               do i=1,3*natoms
                  xx2(i)=x(i)
               end do
               dist=ssx(xx1,xx2,amass,nend)
c
c check for the minimum distance
c
               df=dist-gdist
               if (df.lt.tol) then
                       gdist = dist
                       do i = 1, 3*natoms
                         xx2b(i) = xx2(i)
                       enddo
                       do i=1,3
                         do j=1,3
                            rotas(i,j) = rota (i,j)
                         enddo
                       enddo
               endif
46          continue
44       continue
42    continue
c
c     set xx2 = xx2b
c
      do i=1,3*natoms
         xx2(i)=xx2b(i)
      enddo
c
c compute the parameters for eq (7) in the paper
c
 1    do 35 i=1,3
         b(i)=0.0d0
         do 35 j=1,3
           a(i,j)=0.0d0
 35   continue

      do 90 i=1,natoms

         xm=AMASS(3*I)**2

         ix = 3*i-2
         iy = 3*i-1
         iz = 3*i

         a(1,1) = a(1,1) + xm*(- xx2(ix)*xx1(ix) - xx2(iy)*xx1(iy))
         a(2,1) = a(2,1) + xm*(- xx2(iz)*xx1(iy) )
         a(3,1) = a(3,1) + xm*(  xx2(iz)*xx1(ix) )

         a(1,2) = a(1,2) + xm*(- xx2(iz)*xx1(iy) )
         a(2,2) = a(2,2) + xm*(- xx2(ix)*xx1(ix) - xx2(iz)*xx1(iz))
         a(3,2) = a(3,2) + xm*(- xx2(iy)*xx1(ix) )

         a(1,3) = a(1,3) + xm*(  xx2(iz)*xx1(ix) )
         a(2,3) = a(2,3) + xm*(- xx2(iy)*xx1(ix) )
         a(3,3) = a(3,3) + xm*(- xx2(iy)*xx1(iy) - xx2(iz)*xx1(iz))

         b(1)   = b(1)   + xm*(  xx2(iy)*xx1(ix) - xx2(ix)*xx1(iy))
         b(2)   = b(2)   + xm*(  xx2(iz)*xx1(ix) - xx2(ix)*xx1(iz))
         b(3)   = b(3)   + xm*(  xx2(iz)*xx1(iy) - xx2(iy)*xx1(iz))

 90   continue
c
c solve the system (6) in the paper
c
      call lin (a,b,y,scr,det,1,3,3,1,3)
c
c ensure convergence
c
      do i=1,3
         if (abs(y(i)).gt.shft) then
            if (y(i).gt.shft)  xxn=shft
            if (y(i).lt.-shft) xxn=-shft
            y(i)=xxn
         end if
      end do
c
c obtain sinus and cosinus of the three rotation angles
c
 2    sal = y(1)
      cal = sqrt(1.0d0-sal**2)
      sbe = y(2)
      cbe = sqrt(1.0d0-sbe**2)
      sga = y(3)
      cga = sqrt(1.0d0-sga**2)

c
c construct the rotation matrix
c
      rota(1,1) =   cal*cbe
      rota(1,2) = - sal*cga - cal*sbe*sga
      rota(1,3) =   sal*sga - cal*sbe*cga

      rota(2,1) =   sal*cbe
      rota(2,2) =   cal*cga - sal*sbe*sga
      rota(2,3) = - cal*sga - sal*sbe*cga

      rota(3,1) =   sbe
      rota(3,2) =   cbe*sga
      rota(3,3) =   cbe*cga
c
c rotate coordinates xx2
c
      do i=1,3*natoms
         xscr(i)=xx2(i)
      end do

      do 50 i=1,natoms
         do j=1,3
            sum =0.0d0
            do k=1,3
               idum = 3*(i-1)+k
               sum = sum + rota(j,k)*xscr(idum)
            end do
            idum = 3*(i-1)+j
            xx2(idum)=sum
         end do
 50   continue
c
c add this rotation matrix to rotas
c
      do i=1,3
         do j=1,3
            tmprot(i,j)=0.d0
         enddo
      enddo
      do i=1,3
         do j=1,3
            do k=1,3
               tmprot(i,j)=tmprot(i,j)+rota(i,k)*rotas(k,j)
            enddo
         enddo
      enddo
      do i=1,3
         do j=1,3
            rotas(i,j)=tmprot(i,j)
         enddo
      enddo
c

      do i=1,3*natoms
         x(i)=xx2(i)
      end do
      call center (natoms,n3tm,amass,x)
      dist=ssx(xx1,xx2,amass,nend)
      ipp=ipp+1
c
c  increase number of iterations (from 100 to 5000)                      1117NG04 
c
      if (ipp.gt.9999999) then
         write (outfile,*) 'CALCS: failed convergence',ipp
         stop 'CALCS: failed convergence'
      end if

      if (dist.gt.gdist) then
         irecap=irecap+1
         irr=mod((irecap),3)+1
         y(irr)=-y(irr)
         goto 2
      end if
      gdist=dist
c
c this is the normal return
c
      if ((abs(b(1))+abs(b(2))+abs(b(3))).lt.tol) then
          sval = dist
          return
      endif
      goto 1

1000  format (3f10.5)
2000  format (4f10.5)
3000  format (4f15.7)
4000  format (i4,3f10.5)
      return 
      end
c
C
C***********************************************************************
C  SSX
C***********************************************************************
C
      function  ssx (xx1,xx2,amass,nend)
C
C     this routine computes the distance between two cartesian geometries
C
C
C     CALLED BY:
c            calcs
C
      implicit double precision (a-h,o-z)

      integer nend
      double precision xx1(nend),xx2(nend),amass(nend)

      sum=0.0d0
      do i=1,nend
         sum=sum + (amass(i)*(xx1(i)-xx2(i)))**2
      end do
      ssx=sqrt(sum)

      return

      end

C
C***********************************************************************
C CENTER     
c***********************************************************************
      subroutine center(natoms,n3tm,amass,x) 
C
C     TRANSLATES CENTER OF MASS OF SYSTEM TO SADDLE POINT 
C     ALSO CALCULATES MOMEMT OF INERTIA OR PRODUCT OF ALL 3
C     FOR S. P. 
C
      implicit double precision (a-h,o-z)
c 
      double precision amass(n3tm), x(n3tm)   
      double precision xcm(3)
c
      n3 = n3tm
      ibeg = 1
      iend = natoms
      totm = 0.0d0
      do i = ibeg, iend
         totm = totm + amass(3*I)**2
      enddo
      do k = 1, 3
         sum = 0.0d0
         do i = ibeg, iend
            sum = sum + x(3*(i-1)+k)*amass(3*(i-1)+k)**2
         enddo
         xcm(k) = sum/totm
         do i = k, n3, 3
            x(i) = x(i) - xcm(k)
         enddo
      enddo
      return
      end 
C
C***********************************************************************
C     LIN
C***********************************************************************
C
      SUBROUTINE lin(S,B,Y,T,DET,IND,NS,NRB,NCB,NRY)
C
C            SOLVE A SET OF SIMULTANEOUS LINEAR EQUATIONS
C
C                S * Y = B  (SOLVE FOR Y)
C
C            AND EVALUATE THE DETERMINANT OF S.
C
C    QUANTUM CHEMISTRY GROUP - THE UNIVERSITY OF WASHINGTON - SEATTLE
C
C      THE INVERSE OF S(*) WILL BE FOUND IF NCB=0 ON INPUT.
C      ONLY THE DETERMINANT OF S(*) WILL BE FOUND IF NCB=-1 ON INPUT.
C
C   ON INPUT:
C   --------
C        S(*) - ARRAY CONTAINING THE ELEMENTS OF LEFT HAND ARRAY
C        B(*) - ARRAY OF DIMENSION NRB ROWS BY NCB COLUMNS
C               (WHERE NRB IS >= NS)
C        IND  = 0 IF S IS A SYMMETRIC UPPER TRIANGULAR ARRAY.
C             = 1 IF S IS A SQUARE ARRAY
C        NS   - DIMENSION OF S(*), IE. IF S(*) IS SQUARE THIS IS THE
C               NUMBER OF ROWS OR COLUMNS IN S(*).
C        NRB  - NO. OF ROWS OF THE REGION IN WHICH B(*) IS STORED
C        NCB  - NO. OF COLUMNS OF MATRIX B(*)
C        NRY  - NO. OF ROWS DESIRED IN OUTPUT REGION Y(*)
C
C  ON OUTPUT:
C  ---------
C        OUTPUT WILL BE IN SAME FORMAT AS ARRAY S(*)
C        Y - RECTANGULAR ARRAY OF DIMENSION NS BY NCB AND
C             MAY BE STORED IN Y WITH NRY AS THE NO. OF ROWS
C             (AS LONG AS NRY IS GREATER THAN OR EQUAL TO NS)
C   SCRATCH STORAGE
C        T - DIMENSION NS BY (NS+NCB)
C
C    IF S IS STORED AS SQUARE, T(1) AND S(1) MAY COINCIDE.
C      IF SO, S WILL BE DESTROYED.
C    T(NS**2+1) AND B(1) MAY COINCIDE.
C      IF SO, B WILL BE DESTROYED.
C    Y(1) AND B(1) MAY COINCIDE.
C      IF SO, B WILL BE REPLACED BY Y.
C  HENCE,FOR MINIMUM MEMORY USE, ENTER WITH S ALREADY IN SQUARE
C  FORM, B(1)=S(NS**2+1)=Y(1) AND T(1)=S(1)
C
C     CALLED BY:
C              FORMA,VECCON
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION S(1),B(1),Y(1),T(1)
      DATA ZERO/0.0D0/, TENM9/1.0D-10/, ONE/1.0D0/
C
      NDIM=NS
      NRDIM=NRB
      NCOL=NCB
      NRXDIM=NRY
      IERR=0
      ITIME=2
      NMAX=NDIM
      NMIN=NMAX-1
      NMXSQR=NMAX*NMAX
      NST=NMXSQR+1
      NMAXP=NMAX+1
      SMAX=ZERO
C
C     --- TEST FORMAT OF S(*) ---
C
      IF(IND.EQ.0) GO TO 110
C
C     --- MOVE SQUARE S(*) INTO T(*) ---
C
         DO 100 I=1,NMXSQR
            T(I)=S(I)
            SMAX=MAX(SMAX,ABS(S(I)))
100      CONTINUE
         GO TO 140
110   CONTINUE
      K=1
      IDIM=0
      DO 130 I=1,NMAX
         IJ=I
         JI=IDIM+1
         DO 120 J=1,I
            T(IJ)=S(K)
            T(JI)=S(K)
            SMAX=MAX(SMAX,ABS(S(I)))
            JI=JI+1
            K=K+1
            IJ=IJ+NMAX
120      CONTINUE
         IDIM=IDIM+NMAX
130   CONTINUE
140   CONTINUE
C
C     --- SET THRESHOLD FOR SMALL DIAGONAL ELEMENTS ---
C
      THRESH=SMAX*TENM9
      IF(NCOL.GT.0) GO TO 170
      IF(NCOL.LT.0) GO TO 195
C
C     --- INVERSE WANTED, SET UNIT MATRIX INTO T(*) ---
C
         NCT=NMAX+NMAX
         IJ=NCT*NMAX
         DO 150 I=NST,IJ
            T(I)=ZERO
150      CONTINUE
         IDIM=NMXSQR-NMAX
         DO 160 I=1,NMAX
            IDIM=IDIM+NMAXP
            T(IDIM)=ONE
160      CONTINUE
         GO TO 200
C
C     --- SOLUTION TO LINEAR EQUATIONS WANTED.  PUT B(*) INTO T(*) ---
C
170   CONTINUE
      NCT=NMAX+NCOL
      K=NMXSQR
      IDIM=0
      DO 190 I=1,NCOL
         JI=K
         IJ=IDIM
         DO 180 J=1,NMAX
            JI=JI+1
            IJ=IJ+1
            T(JI)=B(IJ)
180      CONTINUE
         K=K+NMAX
         IDIM=IDIM+NRDIM
190   CONTINUE
      GO TO 200
C  ONLY DETERMINANT WANTED
195   CONTINUE
      NCT=NMAX
200   CONTINUE
      DET=ONE
      IN=0
C
C     --- ELIMINATION TO MAKE LOWER TRIANGLE OF S(*) ALL ZEROES ---
C
      IF(NMIN.EQ.0) GO TO 265
         DO 260 I=1,NMIN
            IMAX=I
            JS=I+1
C  SELECT MAXIMUM ELEMENT IN COLUMN AS PIVOT
            DO 210 J=JS,NMAX
               JN=IN+J
               IMN=IN+IMAX
               TDIFF=ABS(T(JN))-ABS(T(IMN))
               IF(TDIFF.GT.ZERO) IMAX=J
210         CONTINUE
            IMIMAX=I-IMAX
            IF(IMIMAX.EQ.0) GO TO 230
C  INTERCHANGE ROWS TO BRING MAXIMUM ELEMENT TO PIVOT POSITION
               JI=I+IN
               DET=-DET
               IMN=IMAX+IN
               DO 220 J=I,NCT
                  X=T(JI)
                  T(JI)=T(IMN)
                  T(IMN)=X
                  JI=JI+NMAX
                  IMN=IMN+NMAX
220            CONTINUE
230         CONTINUE
               II=I+IN
C  IF MAXIMUM ELEMENT IS ZERO, THE MATRIX IS SINGULAR
            IF(T(II).EQ.ZERO) GO TO 998
C  ELIMINATION ON COLUMN I, STARTING IN ROW I+1
            DO 250 J=JS,NMAX
               JI=J+IN
               IF(T(JI).EQ.ZERO) GO TO 250
                  X=-T(JI)/T(II)
                  IJ=II+NMAX
                  IMN=JI+NMAX
                  DO 240 K=JS,NCT
                     T(IMN)=T(IMN)+X*T(IJ)
                     IJ=IJ+NMAX
                     IMN=IMN+NMAX
240               CONTINUE
250         CONTINUE
            IN=IN+NMAX
260      CONTINUE
C  EVALUATE DETERMINANT AS PRODUCT OF DIAGONAL ELEMENTS.
C  TEST IF ANY DIAGONAL ELEMENT IS SMALL.
  265     CONTINUE
            IFSM=0
            J=1
            DO 270 I=1,NMAX
               DET=DET*T(J)
               IF(ABS(T(J)).LE.THRESH) IFSM=J
               J=J+NMAX+1
270         CONTINUE
C  RETURN IF ONLY DETERMINANT WAS WANTED
            IF(NCOL.LT.0)RETURN
            IF(IFSM.NE.0) GO TO 999
            IF(NMIN.EQ.0) GO TO 320
C  ELIMINATE UPPER TRIANGLE OF S
            IN=NMXSQR-NMAX
         DO 310 I=1,NMIN
            IA=NMAXP-I
            II=IN+IA
            IJ=IN+1
            DO 300 J=2,IA
               IF(T(IJ).EQ.ZERO) GO TO 295
                  X=-T(IJ)/T(II)
                  JI=NMXSQR+J-1
                  IMN=NMXSQR+IA
                  DO 290 K=NMAXP,NCT
                     T(JI)=T(JI)+X*T(IMN)
                     JI=JI+NMAX
                     IMN=IMN+NMAX
290               CONTINUE
  295             CONTINUE
                  IJ=IJ+1
300         CONTINUE
            IN=IN-NMAX
310      CONTINUE
C  DIVIDE BY DIAGONALS OF S
320   CONTINUE
      IF(NCOL.NE.0) GO TO 22
      K=1
      IN=0
      IF(IND.EQ.0)GO TO 231
C  SOLVING LINEAR EQUATION, OR S INVERSE, S NOT SYMMETRIC
      JUP=NMAX
      GO TO 232
 22   IN=0
      JUP=NCOL
232   DO 43 I=1,NMAX
      IJ=NMXSQR+I
      II=IN+I
      IX=I
      DO 44 J=1,JUP
      Y(IX)=T(IJ)/T(II)
      IJ=IJ+NMAX
      IX=IX+NRXDIM
  44  CONTINUE
      IN=IN+NMAX
  43  CONTINUE
      RETURN
C  S INVERSE, STORED AS UPPER TRIANGLE SYMMETRIC
231   CONTINUE
      DO 45 I=1,NMAX
      II=IN+I
      JI=NMXSQR+I
      DO 46 J=1,I
      Y(K)=T(JI)/T(II)
      K=K+1
      JI=JI+NMAX
  46  CONTINUE
      IN=IN+NMAX
  45  CONTINUE
      GO TO 1000
C
C      --- ERROR BRANCH ---
C
998   CONTINUE
      IF(NCOL.LT.0) THEN
        DET=ZERO
      ELSE
        WRITE(6,900)
900   FORMAT(1X,52HTHE MAXIMUM ELEMENT IS ZERO. THE MATRIX IS SINGULAR.)
        STOP
      END IF
      GO TO 1000
999   CONTINUE
        WRITE(6,910) T(IFSM),THRESH
910   FORMAT(1X,'A DIAGONAL ELEMENT IS SMALLER THAN THRESHOLD.',/,
     *1X,'ELEMENT =',E12.5,' THRESHOLD =',E12.5)
        STOP
1000  CONTINUE
      RETURN
C...END OF LIN
      END

c****************************************************************************
c  INTERP
c****************************************************************************
c
      subroutine interp(nebinp, ximg)
c
c     Created:  July 2004, by Nuria Gonzalez-Garcia
c     Purpose:  Linear interpolation between two structures
c
      use files, only : iuimg, outfile
      use input, only : cartgeom, nebopt
c
      implicit none
c
      type (nebopt) :: nebinp
      type (cartgeom) :: ximg(0:nebinp%nimg+1)
c
      integer i, j
      double precision fac, angtoau
      angtoau = 0.5291772083d0
c
      do i = 0, nebinp%nimg+1
         fac = (1.0d0/(nebinp%nimg+1))*i
         do j = 1, 3*nebinp%rgeom%natoms
            ximg(i)%angcoord(j)= 
     &                     (1-fac)*nebinp%rgeom%angcoord(j)   
     &                   +     fac*nebinp%pgeom%angcoord(j)   
            ximg(i)%aucoord(j)= ximg(i)%angcoord(j)/angtoau
         enddo
         ximg(i)%natoms = nebinp%rgeom%natoms
         ximg(i)%atm = nebinp%rgeom%atm
      enddo
c
c print out the initial images along the NEB path
c
      open (unit=iuimg, status='unknown', file=nebinp%imgfile, err=9991)
      do i = 0, nebinp%nimg+1
         write(iuimg,100) i
         write(iuimg,*) nebinp%rgeom%natoms
         do j = 1, nebinp%rgeom%natoms
            write(iuimg,200) j, ximg(i)%angcoord(3*j-2),
     &                          ximg(i)%angcoord(3*j-1),
     &                          ximg(i)%angcoord(3*j)
         enddo
      enddo
      close (iuimg)
      return

 100  format ('*** Image # ', 3x, i4)
 200  format(9x,i4,t20,d15.8,t40,d15.8,t60,d15.8)
9991  write (outfile,*) 'Error creating NEB image file'
      stop 'interpolate 1'

      end
c
c
c****************************************************************************
c  TANGCALC
c****************************************************************************
c
c
      subroutine tangcalc(ximga, ximgb, ximgc,
     &                    vimga, vimgb, vimgc,
     &                    natoms, n3tm, tau, nebalg)
c
c     Created:  July 2004, by Nuria Gonzalez-Garcia
c     Purpose:  Tangent calculation at each image as defined by Jonsson
c               et al. in  J Chem Phys  113(22), 9978 (2000)
                 
      use files, only : outfile
c
      implicit none
c
      integer natoms, n3tm
      double precision ximga(n3tm), ximgb(n3tm), ximgc(n3tm)
c
      double precision vimga, vimgb, vimgc
c
      integer i,j
      integer nebalg
c
      double precision tau(n3tm)
      double precision tau_plus(n3tm)
      double precision tau_minus(n3tm)
      double precision deltaVmax, deltaVmin
c
      double precision dif_plus, dif_minus
      double precision ltau 
c
c WE DISTINGUISH BETWEEN THE ORIGINAL TANGENT DEFINITION                0621NG05
c AND THE NEWER ONE FROM 2000 	                                        0621NG05
c (both can be found in the J Chem Phys 2000 paper)                     0621NG05
c
c When using the original algorithm (B-NEB), just simply
c substract the geometry vectors
c
      if (nebalg .eq. 4) then
          do j = 1, n3tm
              tau(j) = ximgc(j) - ximga(j)
          end do
c Otherwise (always use the newer definition)                           0621NG05
      else                                                              0621NG05
c	
c 1. common parameters for the tangent calculation*****

c Tau-plus: energy is increasing with the number of images
c
          do j = 1, n3tm
              tau_plus(j) =  ximgc(j) -  ximgb(j)
          enddo
c
c Tau-minus: energy is decreasing with the number of images
c
          do j = 1, n3tm
              tau_minus(j) = ximgb(j) - ximga(j)
          enddo
c
c deltaVmax and deltaVmin: for minima and maxima images
c
          dif_plus = abs(vimgc- vimgb)
          dif_minus = abs(vimga - vimgb)
c
          deltaVmax = max (dif_plus,dif_minus)
          deltaVmin = min (dif_plus,dif_minus)
c
c
c check the energy of the 3 images
c
          if ((vimgc .gt. vimgb) .and. (vimgb . gt. vimga)) then
             tau(:n3tm) = tau_plus(:n3tm)
          elseif ((vimgc .lt. vimgb) .and. (vimgb . lt. vimga))
     &                                                     then
             tau(:n3tm) = tau_minus(:n3tm)
          else 
                 if (vimgc .gt. vimga) then
                    do j = 1, n3tm
                        tau (j) = tau_plus(j) * deltaVmax +
     &                            tau_minus(j) * deltaVmin
                    enddo
                 else
                    do j = 1, n3tm
                        tau (j) = tau_plus(j) * deltaVmin +
     &                            tau_minus(j) * deltaVmax
                    end do
                 endif 
          endif
c
c  tangent vector tau(j) needs to be normalized
c
          ltau = 0.0d0
          do j = 1, n3tm
              ltau = ltau + tau(j)*tau(j)
          end do
c
          do j = 1, n3tm
              tau(j) = tau(j) / sqrt(ltau)
          end do   
c

          end if
c
      return
      end
c
c****************************************************************************
c  FORCALC
c****************************************************************************
c
      subroutine forcalc(kspr, ximga, ximgb, ximgc, 
     &                   grd, tau, tfor, n3tm, nebalg,maximg,nimg,      0622NG05
     &                   nitera)                                        0623NG05
c
c     Created:  July 2004, by Nuria Gonzalez-Garcia
c     Purpose: Obtain the total force for each image, composed by
c              the spring force and the perpendicular component of
c              the true force (spring force calculated as defined by
c              Jonsson et al. in  J Chem Phys  113(22), 9978 (2000)
c
      implicit none
c
      integer n3tm
      double precision ximga(n3tm), ximgb(n3tm), ximgc(n3tm)
c
      integer nebalg
      double precision kspr
      double precision grd(n3tm),gper(n3tm),fspr(n3tm),
     &                 tfor(n3tm),tau(n3tm)
c
      double precision dif1(n3tm)
      double precision dif2(n3tm)
      double precision sum1, sum2
      integer j
c
c Option added for CI-NEB                                               0622NG05
c
      integer maximg,nimg,nitera                                        0622NG05
c
c Two conditions: CI-NEB algorithm and Highest energy image             0622NG05
c The paper says this change should be introduced after some iterations 0622NG05
c
      if (nebalg.eq.2 .and. nimg.eq.maximg .and. nitera.gt.5) then      0622NG05

          do j = 1, n3tm                                                0622NG05
              tfor(j) = -grd(j) + (2*grd(j)*tau(j))*tau(j)              0622NG05
          end do                                                        0622NG05
c
      else                                                              0622NG05
c
c spring force evaluation
c
          do j = 1, n3tm
              dif1(j) = ximgc(j) - ximgb(j)
          enddo
c
          do j = 1, n3tm
              dif2(j) = ximgb(j) - ximga(j)
          enddo
c
          sum1 = 0.0d0
          do j = 1, n3tm
              sum1 = sum1 + dif1(j)*dif1(j)
          end do
          sum1 = sqrt(sum1)
c
          sum2 = 0.0d0
          do j = 1, n3tm
              sum2 = sum2 + dif2(j)*dif2(j)
          end do
          sum2 = sqrt(sum2)
c
c spring force (parallel component)
c
          do j = 1, n3tm
              fspr(j) = kspr * (sum1-sum2) *tau(j)
          end do
c
c use the original formula (B-NEB) if we decided so, 0817PJ04
c
          if (nebalg .eq. 4) then
             sum1 = 0.0d0
             do j = 1, n3tm
                 sum1 = sum1 + (dif2(j)-dif1(j))*tau(j)
             end do
c
             do j = 1, n3tm
                 fspr(j) = kspr * sum1 * tau(j)
             end do 
          end if

c
c true force (perpendicular component)
c
          sum1 = 0.0d0
          do j = 1, n3tm
              sum1 = sum1 + grd(j) * tau(j)
          end do
c
          do j =1, n3tm 
              gper(j) = grd(j) - sum1*tau(j)
          end do
c
c total force
c
          do j = 1, n3tm
              tfor(j) = fspr(j) - gper(j)
          end do
c
      end if                                                            0622NG05
c
      return 
      end
c
c******************************************************************************
c  OPTNEBDISP
c******************************************************************************
c
      subroutine optnebdisp( iter, geom, ener, grad, xxi, gcomp, gtol ,
     &  nimg)
c
c     Subroutine optnebdisp
c
c     Created:  July 16, 1999 by J. M. Rodgers
c     Revised:  August 30, 2004 by Nuria Gonzalez-Garcia
c     Purpose:  Display all information for the current optimization step.
c
c     Revision: including a new variable to print the image number
c     Called by:  newt, newt2
c     Calls:  
c
c     Variables defined here:  none.
c
      use files, only : outfile
      use input, only : cartgeom

      implicit none

      type (cartgeom) :: geom

      integer iter, i, nimg                                             0830NG04
      double precision  ener, grad(3*geom%natoms), xxi(3*geom%natoms)
      double precision  gcomp, gtol

      write(outfile,1000)  iter
      write(outfile,1001)  nimg                                         0830NG04
      write(outfile,1150)  ener
      write(outfile,1200)
      write(outfile,1250)  -grad
      write(outfile,1300)  gcomp, gtol
c
C Information not printed because the output would become too long      0208NG06
c      write(outfile,1350)                                              0208NG06
c      write(outfile,1250)  xxi                                         0208NG06
c      write(outfile,1450)                                              0208NG06
c      do 20 i=1, geom%natoms                                           0208NG06
c         write(outfile,1500)  geom%atm(i), geom%aucoord(3*i-2),        0208NG06
c     *       geom%aucoord(3*i-1), geom%aucoord(3*i)                    0208NG06
  20  continue
      write(outfile,1550)
      do 40 i=1, geom%natoms
         write(outfile,1500)  geom%atm(i), geom%angcoord(3*i-2),
     *      geom%angcoord(3*i-1), geom%angcoord(3*i)
  40  continue
      write(outfile,*)

1000  format(/2x,14('-'),/2x,'Iteration: ',i3,/2x,14('-')/)
1001  format(/6x,14('-'),/6x,'Image number: ',i3,/6x,14('-')/)          0830NG04
1150  format(/8x,'Image Energy:',t30,f19.12)
1200  format(/8x,'Total or Adjusted Force:',/)
1250  format(t20,d15.8,t40,d15.8,t60,d15.8)
1300  format(/8x,'RMS Force = ',d10.3,t40,
     *          'Convergence Requirement = ',d10.3)
c1350  format(/8x,'Scaled Step:')
c1450  format(//8x,'Atomic Coordinates (in a.u.):',//8x,'Atom', t28, 'X',
c     *         t48, 'Y', t68, 'Z'/)
1500  format(9x,a2,t20,d15.8,t40,d15.8,t60,d15.8)
1550  format(//8x,'Image Coordinates (in ang.):',//8x,'Atom', t28, 'X',
     *         t48, 'Y', t68, 'Z'/)  

      return
      end
c
