c
c******************************************************************************
c  NEBMIN
c******************************************************************************
c
      subroutine nebmin(optinp, ind, n, ierr)
c
      use files, only: outfile
      use input, only : mlopt
c
      implicit none
c
      integer            ind(*), n, ierr, optm
      type (mlopt)    :: optinp
c
      character*10     :: aswit(0:4)             
      data aswit /'BFGS','DFP','NR','EF','GAUEXT'/
c
      optm = optinp%nebinp%optm
c
c use BFGS or DFT update the inverse Hessian
c
      if (optm .eq. 1 .or. optm .eq. 2) then
         call nebnr(optinp, ind, n, ierr)
c
c Hessian are keep frozen between recalculation points
c
      else if (optm .eq. 3) then
         call nebnr2(optinp, ind, n, ierr)
c
c Use Vanderbilt Modified Broyden method
c
      else if (optm .eq. 4) then
         call nebvb(optinp, ind, n, ierr)
      else
         write(outfile,*) 'NEB optimization (OPTM): '
         write(outfile,*) aswit(optm+1),' has NOT been implemented.'     
         stop 'nebmin 1'
      end if
 
      return
      end

c     
c******************************************************************************
c  NEBNR
c******************************************************************************
c     
      subroutine nebnr(optinp, ind, n, ierr)
c
c     Created:  July 2004 by Jingzhi Pu
c               Adapted from the NEWT2 routines 
c
c     Purpose:  To perform NR optimization with BFGS or DFP hessian
c        updates for NEB optimization
c
      use files, only : iuimg                                           0927NG04
      use files, only : outfile
      use input, only : cartgeom, mlopt, mlinp
c
c     use optimize, only : ener, grad, hess
c
      implicit none
c
      integer            ierr
      type (mlopt)    :: optinp
      logical         :: check
c
c Variable created to include the possibility of                        0927NG04
c  reading the neb.img file without creating it.                        0927NG04
c If filexist=true the reorient and interp subroutines                  0927NG04
c won't be called                                                       0927NG04
      logical         :: filexist                                       0927NG04

c
c bug fix, indimg should be integer                                     1026PJ04
      integer, dimension(:), allocatable :: indimg, work                1026PJ04
      integer  idorec, nrecal, n3tm, n, ind(*), ndim, nimg, natoms   
      integer  jrank, its, mxind, fail, linmin, i, j, status, k
      double precision, dimension(:), allocatable :: xxi, x0, dx0,
     *    deltag, hdg
      double precision, dimension(:,:), allocatable :: himgin
      double precision, dimension(:,:), allocatable :: hscr
      double precision, dimension(:,:), allocatable :: himg
      double precision  gtol, gcomp, abxxi, fret, abgc,
     *    detf, stepc, stepmx, d, fac, fae, sumdg, sumxi, fad, sum

      double precision, parameter :: eps = 1.0d-14
      double precision, parameter :: angtoau = 0.5291772083d0
      double precision, parameter :: maxstep = 1.0d0

c
c NEB images and total gradient to be minimized
c
      type (cartgeom), dimension(:), allocatable :: ximg
      double precision, dimension(:), allocatable :: vimg
      double precision, dimension(:), allocatable :: gimg
c
c NEB convergencia criterium set to RMS.le. 3.0d-4 (as Gaussian)        0623NG05
c
      double precision nebgtol                                          0623NG05
c
      natoms = optinp%nebinp%rgeom%natoms
      n3tm = 3*natoms
      nimg = optinp%nebinp%nimg
      ndim = n3tm*nimg
c
      nebgtol = 3.0d-4
      its = 0                                                           0623NG05
c
      filexist = .false.                                                0927NG04

      allocate (indimg(n),work(ndim))
      allocate (xxi(ndim), x0(ndim),dx0(ndim),deltag(n), 
     *          himgin(n,n),hdg(n),himg(ndim,ndim), hscr(n,n) )

c
c ******** NEB initialization, can be moved to a separate subroutine ****
c *****Generation of the initial set of images*****

      allocate (ximg(0:nimg+1))
      allocate (vimg(0:nimg+1))
      allocate (gimg(ndim))

c
c if we restart from a previous run, read in image from an external file
c

      inquire (file=optinp%nebinp%imgfile , exist=filexist)             1022PJ04
      if (filexist) then                                                1022PJ04
         write(outfile,3) optinp%nebinp%imgfile                         1022PJ04
         open (unit=iuimg, status='unknown',                            1022PJ04
     &         file=optinp%nebinp%imgfile, err=9992)                    1022PJ04
         do i = 0, optinp%nebinp%nimg+1                                 1022PJ04
            read(iuimg,*)                                               1022PJ04
            read(iuimg,*)                                               1022PJ04
            do j = 1, optinp%nebinp%rgeom%natoms                        1022PJ04
               read(iuimg,4) k, ximg(i)%angcoord(3*j-2),                1022PJ04
     &                          ximg(i)%angcoord(3*j-1),                1022PJ04
     &                          ximg(i)%angcoord(3*j)                   1022PJ04
            enddo                                                       1022PJ04
            ximg(i)%aucoord = ximg(i)%angcoord/angtoau                  1022PJ04
            ximg(i)%natoms = optinp%nebinp%rgeom%natoms                 1022PJ04
            ximg(i)%atm = optinp%nebinp%rgeom%atm                       1022PJ04
         enddo                                                          1022PJ04
         close (iuimg)                                                  1022PJ04
 3    format ('NEB initial images are read from file: ', a20)           1022PJ04
 4    format(9x,i4,t20,d15.8,t40,d15.8,t60,d15.8)                       1022PJ04

c
c otherwise, obtain image from reactant and product
c

      else                                                              1022PJ04
c
c Reorientation of PRODUCT system (with the REACTANT system)
c CHEN algorithm
c
         call reorient(optinp%nebinp%rgeom%angcoord,
     &                 optinp%nebinp%pgeom%angcoord,
     &                 natoms,n3tm,optinp%nebinp%rgeom%atmmss)    
c
c Interpolation between the two initial structures
c
         call interp(optinp%nebinp, ximg)

      end if

c ************************************************************************

      fail = 0
c
c HREC: number of iterations between recalculation of the HEssian       1029NG04
c
      idorec = optinp%hrec
      nrecal = 0
      linmin = 1
      status = 0

c
c if use nebalg is TS, we should not do a line min search, since
c for the TS image, it is an uphill search. Another reason to comment
c line minimization search is that we do not know the energy objective
c function after the projection per se.
c
c     if (optinp%iop .gt. 4) then
c        linmin = 0
c     endif
c

c
c  Set up the default convergent values for the energy and derivative
c  (use the one used in GCOMP as the NEB convergence)  
c
c      if (optinp%gcomp .le. eps) then                                  0623NG05
c         gtol = 1.0d-7                                                 0623NG05
c      else                                                             0623NG05
c         gtol = optinp%gcomp                                           0623NG05
c      endif                                                            0623NG05
c      if (optinp%nebinp%nebiter .lt. 0) goto 300                       0623NG05



c
c  Get initial gradient
c
      call nebghk(optinp%nebinp, ximg, vimg, gimg,its)

c      gcomp = abs( gimg(1) )                                           0623NG05
c      do 5 i=2, ndim                                                   0623NG05
c         abgc = abs( gimg(i) )                                         0623NG05
c         if (gcomp.lt.abgc)  gcomp = abgc                              0623NG05
c   5  continue                                                         0623NG05
c
      abgc = 0.0d0                                                      0623NG05
      do 5 i=1, ndim                                                    0623NG05
        abgc = abgc + (gimg(i))**2                                      0623NG05
        gcomp = sqrt(abgc)                                              0623NG05
   5  continue                                                          0623NG05

c
c  Make initial display of info
c
         do 10 i=1, ndim
            xxi(i) = 0.0000d0
  10     continue
         do i = 1, nimg
           call optnebdisp(0, ximg(i), vimg(i), gimg((i-1)*n3tm+1),     1111NG04
c     *                  xxi((i-1)*n3tm+1), gcomp, gtol, i)              1111NG04
     *                  xxi((i-1)*n3tm+1), gcomp, nebgtol, i)           0623NG05
         end do
c
c  Check if the geometry is already optimized.
c
      if (gcomp.le.nebgtol) then
         status = 3
         goto 300
      endif
c
c  Set initial hessian (by hhook if INITHESS is on; I otherwise)
c  (use the options available in MULTIOPT section)
c
      if (optinp%ihunit.eq.1) then
c
c We use the block diagonal low-level electronic structure for
c each image as an start
c
         call nebhhk(optinp%nebinp,ndim,nimg,ximg,gimg,himg,
     &               optinp%constant)    
 
      elseif (optinp%ihunit.eq.0) then
 
c
c Currently, we simply use a scaled unit matrix as a start 
c
         do 21 i=1, ndim
            do 22 j=1, ndim
               himg(i,j) = 0.0d0
  22        continue
            himg(i,i) = optinp%hscale
  21     continue

      endif
c
c  Get inverse of the small hessian (fix 6 or 5 cartesians for
c  each image to remove the overall translation and rotation)
c Quant val n? juny2005
      k = n/nimg
      do i = 1, nimg
         do j = 1, k
             indimg((i-1)*k+j) = (i-1)*n3tm + ind(j)
         end do
      end do

      do 23 i=1, n
         do 24 j=1, n
            himgin(i,j) = himg(indimg(i),indimg(j))
            hscr(i,j) = himgin(i,j)
  24     continue
  23  continue

c
c    Pu updated the subroutine to get the inverse of the Hessian (following 
c    the G98+NEB program (MXLNEQ does not seem to work properly)
    
c     call mxlneq( himgin(:n,:n),n,n,detf,jrank,eps,work,0,n )
c
      call rminv(hscr, himgin, n)

      sum = 0.0
      do 25 i=1, n
         do 26 j=1, n
            sum = sum + himgin(i,j)
  26     continue
  25  continue
      sum = sum - dble(n)
      write(outfile,'(/a,3x,d12.5)') 'Sum that should be ~0:', sum
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c  MAIN LOOP to perform the geometry optimization
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
      do 200 its=1, optinp%nebinp%nebiter
c
c  initialize dx0 and x0
c
         do 40 i=1, ndim
               dx0(i) = gimg(i)
  40     continue
         do i = 1, nimg
             do j = 1, n3tm
                 x0((i-1)*n3tm + j) = ximg(i)%aucoord(j)
             end do 
         end do
c         write(outfile,'(/,a,i3)') 'Initial geometry at step ', its
c         write(outfile,1018) x0
1018     format(3(1x,f10.6))
c         write(outfile,'(/,a,i3)') 'Initial gradient at step ', its
c         write(outfile,1023) dx0
1023     format(3(1x,d15.8))
c
c  Calculate Newton-Raphson step
c
         do 29 i=1, ndim
            xxi(i) = 0.0d0
  29     continue
         do 30 i=1, n
            do 31 j=1, n
               xxi(indimg(i)) = xxi(indimg(i)) 
     &                          - himgin(i,j)*dx0(indimg(j))
  31        continue
  30     continue
c
c  Scale calculated step so that rms value not greater than scale
c
         sum = 0.0d0
         do 7 i=1, ndim
            sum = sum + xxi(i)*xxi(i)
   7     continue
         sum = sqrt(sum)
         if (sum.gt.optinp%scale)  xxi = xxi*optinp%scale/sum

         stepc = abs(xxi(1))
         mxind = 1
         do 105 i=2, ndim
            abxxi = abs(xxi(i))
            if (stepc.lt.abxxi) then
                stepc = abxxi
                mxind = i
            endif
 105     continue
c         write(outfile,'(/,a,i3)') 'XXI at step ', its
c         write(outfile,1018) xxi
c
c  Add to make sure that step not zero before send into linmn.
c
         if (stepc .eq. 0.0d0) then
            status = 4
            goto 300
         endif
c
c  ... then scale the Newton-Raphson step
c
         stepmx = optinp%scale/stepc
c
c  ... we probably cannot do the line minimization step, because
c      the NEB energy objective function after projections is 
c      actually unknown. comment out at this point
c
c        if (linmin.eq.1) then
c           call linmn(x0, xxi, ndim, fret, stepmx)
c           sum = 0.0d0
c           do 8 i=1, n3tm
c              sum = sum + xxi(i)*xxi(i)
c  8        continue
c           sum = sqrt(sum)
c           if (sum.gt.optinp%scale)  xxi = xxi*optinp%scale/sum
c           stepc = abs(xxi(mxind))
c        endif

c
c
c  Move to a new geometry and calculate new energy and gradient
c  Be careful with units - Gaussian is called with angcoord, yet the
c    optimizer operates on aucoord
c
         do i=1, nimg
             do j = 1, n3tm
                k = (i-1)*n3tm + j
                ximg(i)%aucoord(j) = x0(k) + xxi(k)
             end do
             ximg(i)%angcoord = ximg(i)%aucoord*angtoau
         end do

c         write(outfile,'(/,a)') 'Ang. Geom after scaling'
c         write(outfile,1018) ximg%angcoord(:dim)
c         write(outfile,'(/,a)') 'A.U. Geom after scaling'
c         write(outfile,1018) ximg%aucoord(:n3tm)
c
c  Get gradient and energy
c
         call nebghk(optinp%nebinp, ximg, vimg, gimg,its)
c         
c         gcomp = abs(gimg(1))                                          0623NG05
c         do 130 i=2, ndim                                              0623NG05
c            abgc = abs(gimg(i))                                        0623NG05
c            if (gcomp.lt.abgc)  gcomp=abgc                             0623NG05
         abgc = 0.0d0                                                   0623NG05
         do 130 i=1, ndim                                               0623NG05
             abgc = abgc + (gimg(i))**2                                 0623NG05
             gcomp = sqrt(abgc)                                         0623NG05
 130     continue
c
c  Test for convergence
c
         if (gcomp.le.nebgtol) then
            status = 1
            goto 300
         endif
c
c  Test for magnitude of stepsize
c
         if (stepc.lt.optinp%stptol) then
            fail = 1
            write(outfile, 1350) stepc
1350        format(/,'Maximum displacement component change smaller ',
     *               'than STPTOL:',3x,d12.5)
            if (optinp%retry .eq. 0)  then
               status = 2
               goto 300
            endif
         endif

         if (fail .eq. 1) then
            write(outfile, 1375)
1375        format(/,'Switching to full Newton optimization')
            idorec = 1
            nrecal = idorec
            linmin = 0
            fail = 0
         else
            nrecal = nrecal+1
         endif
c
c  Display current step in optimization
c
         do i = 1, nimg
           call optnebdisp(its, ximg(i), vimg(i), gimg((i-1)*n3tm+1),   1111NG04
c     *                  xxi((i-1)*n3tm+1), gcomp, gtol, i)              1111NG04
     *                  xxi((i-1)*n3tm+1), gcomp, nebgtol, i)           0623NG05
         end do
c
c  Get new hessian if necessary (but not if on last step of optimization.
c
         if (nrecal.eq.idorec .and. its.ne.optinp%nebinp%nebiter) then
            nrecal = 0
            write (outfile, 1400)
 1400       format(/,'Hessian recalculated.')
            call nebhhk(optinp%nebinp,ndim,nimg,ximg,gimg,himg,
     &                  optinp%constant)    
c
c  Get inverse of the small hessian
c
            do 101 i=1, n
               do 102 j=1, n
                  himgin(i,j) = himg(ind(i),ind(j))
                  hscr(i,j) = himgin(i,j)
 102           continue
 101        continue

c
c           call mxlneq( himgin(:n,:n),n,n,detf,jrank,eps,work,0,n )
c
            call rminv(hscr, himgin, n)

            sum = 0.0
            do 103 i=1, n
               do 104 j=1, n
                  sum = sum + himgin(i,j)
 104           continue
 103        continue
            sum = sum - dble(n)
            write(outfile,'(/a,3x,d12.5)') 'Sum that should be ~0:', sum
c
c  Otherwise, do BFGS or DFP update
c
         else
c
c  ... Compute differences of gradients and difference times hessin
c
            do 152 i=1, n
               deltag(i) = gimg(indimg(i)) - dx0(indimg(i))
 152        continue
            do 153 i=1, n
               hdg(i) = 0.0d0
               do 154 j=1, n
                  hdg(i) = hdg(i)+himgin(i,j)*deltag(j)
 154           continue
 153        continue
c
c  ... Calculate dot products for the denominators
c
            fac = 0.0d0
            fae = 0.0d0
            sumdg = 0.0d0
            sumxi = 0.0d0
            do 155 i=1, n
               fac = fac + deltag(i)*xxi(indimg(i))
               fae = fae + deltag(i)*hdg(i)
               sumdg = sumdg + deltag(i)*deltag(i)
               sumxi = sumxi + xxi(indimg(i))*xxi(indimg(i))
 155        continue
c
c  ... Skip update if fac not sufficiently positive
c
            if (fac*fac.gt.eps*sumdg*sumxi) then
               fac = 1.0d0/fac
               fad = 1.0d0/fae
c
c  ... Compute DFP update
c
               do 156 i=1, n
                  do 157 j=1, n
                     himgin(i,j) = himgin(i,j)
     *                  + fac*xxi(indimg(i))*xxi(indimg(j))
     *                  - fad*hdg(i)*hdg(j)
 157              continue
 156           continue
c
c  ... Add on special BFGS element if BFGS has been chosen.
c
               if (optinp%nebinp%optm.eq.1) then
 
                  do 160 i=1, n
                     deltag(i) = fac*xxi(indimg(i)) - fad*hdg(i)
 160              continue
                  do 158 i=1, n
                     do 159 j=1, n
                        himgin(i,j) = himgin(i,j)
     *                     + fae*deltag(i)*deltag(j)
 159                 continue
 158              continue
                 write (outfile, 1410)
1410             format(/,'Hessian updated using BFGS formula')
 
               elseif (optinp%algrthm.eq.2) then
                  write (outfile,1420)
 1420             format(/,'Hessian updated using DFP formula')
 
               endif
            else
               write (outfile,1092)
1092           format(/,'Update skipped because factor too small.')
            endif
  
         endif
 
         write(outfile,*) ' effective dimension: n = ', n
c         write(outfile,*) '--- Hessian after update ---'
c         write(outfile,1027) himgin(:n,:n)
c1027     format(6(1x,d12.5))

 200  continue
c
c  If at this point the iterations have maxed out - print message and
c    exit routine.
c
      write (outfile, 2200)
2200  format (/5x,'NEB OPTIMIZATION FAILURE: Max iterations reached.',/)     
      ierr = 1

      return

 300  continue
c
c  Display final step in optimization and print appropriate exit message.
c

      if (status .eq. 1) then
         do i = 1, nimg
           call optnebdisp(its, ximg(i), vimg(i), gimg((i-1)*n3tm+1),   1111NG04
c     *                  xxi((i-1)*n3tm+1), gcomp, gtol, i)              1111NG04
     *                  xxi((i-1)*n3tm+1), gcomp, nebgtol, i)           0623NG05
         end do
         write (outfile, 2000)
      elseif (status .eq. 2) then
         do i = 1, nimg
           call optnebdisp(its, ximg(i), vimg(i), gimg((i-1)*n3tm+1),   1111NG04
c     *                  xxi((i-1)*n3tm+1), gcomp, gtol, i)              1111NG04
     *                  xxi((i-1)*n3tm+1), gcomp, nebgtol, i)           0623NG05
         end do
         write (outfile, 2100)
         ierr = 1
      elseif (status .eq. 3) then
         write (outfile, 2300)
      elseif (status .eq. 4) then
         write (outfile, 2400)
         ierr = 1
      endif

2000  format (/80('*'),/28x,'OPTIMIZATION SUCCESSFUL.',
     *          /80('*'),/)
2100  format (/5x,'OPTIMIZATION FAILURE: Geometry not changing.',/)
2300  format (/80('*'),/26x,'GEOMETRY ALREADY OPTIMIZED.',
     *          /80('*'),/)
2400  format (/5x,'OPTIMIZATION FAILURE: Step Size is 0.',/)

      return

9992  write (outfile,*) 'Error reading NEB image file'                  1022PJ04
      stop 'nebnr2 1'                                                   1022PJ04

      end
c
c******************************************************************************
c  NEBNR2
c******************************************************************************
c
      subroutine nebnr2(optinp, ind, n, ierr)
c
c     Created:  July 2004 by Jingzhi Pu
c               Adapted from the NEWT2 routines 
c
c     Purpose:  To perform NR optimization without BFGS or DFP hessian
c        updates for the NEB optimization. Hessian are kept frozen between
c        recalculation steps
c
      use files, only : iuimg                                           0927NG04
      use files, only : outfile
      use input, only : cartgeom, mlopt, mlinp
c
c     use optimize, only : ener, grad, hess
c
      implicit none
c
      integer            ierr
      type (mlopt)    :: optinp
      logical         :: check
c
c Variable created to include the possibility of                        0927NG04
c  reading the neb.img file without creating it.                        0927NG04
c If filexist=true the reorient and interp subroutines                  0927NG04
c won't be called                                                       0927NG04
      logical         :: filexist                                       0927NG04

c bug fix, indimg should be integer
      integer, dimension(:), allocatable :: indimg, work, indx          1026PJ04
      integer  idorec, nrecal, n3tm, n, ind(*), ndim, nimg, natoms   
      integer  jrank, its, mxind, fail, linmin, i, j, status, k
      double precision, dimension(:), allocatable :: xxi, x0, dx0,
     *    deltag, prod, hdg, tempsol
      double precision, dimension(:,:), allocatable :: luhess
      double precision, dimension(:,:), allocatable :: himg
      double precision  gtol, gcomp, abxxi, fret, abgc,
     *    detf, stepc, stepmx, d, fac, fae, sumdg, sumxi, fad, sum,
     *    chksum

      double precision, parameter :: eps = 1.0d-14
      double precision, parameter :: angtoau = 0.5291772083d0
      double precision, parameter :: maxstep = 1.0d0

c
c NEB images and total gradient to be minimized
c
      type (cartgeom), dimension(:), allocatable :: ximg
      double precision, dimension(:), allocatable :: vimg
      double precision, dimension(:), allocatable :: gimg
c
c NEB convergencia criterium set to RMS.le. 3.0d-4 (as Gaussian)        0623NG05
c
      double precision nebgtol                                          0623NG05
c
      natoms = optinp%nebinp%rgeom%natoms
      n3tm = 3*natoms
      nimg = optinp%nebinp%nimg
      ndim = n3tm*nimg
c
      nebgtol = 3.0d-4
      its = 0                                                           0623NG05
c
      filexist = .false.                                                0927NG04

      allocate (indimg(n), work(ndim), indx(ndim))                      1026PJ04
      allocate (xxi(ndim), x0(ndim), dx0(ndim), deltag(n), 
     *          luhess(n,n), prod(ndim), hdg(n),himg(ndim,ndim),
     *          tempsol(n) )

c
c ******** NEB initialization, can be moved to a separate subroutine ****
c *****Generation of the initial set of images*****

      allocate (ximg(0:nimg+1))
      allocate (vimg(0:nimg+1))
      allocate (gimg(ndim))

c
c if we restart from a previous run, read in image from an external file
c
      inquire (file=optinp%nebinp%imgfile , exist=filexist)             1022PJ04
      if (filexist) then                                                1022PJ04
         write(outfile,3) optinp%nebinp%imgfile                         1022PJ04
         open (unit=iuimg, status='unknown',                            1022PJ04
     &         file=optinp%nebinp%imgfile, err=9992)                    1022PJ04
         do i = 0, optinp%nebinp%nimg+1                                 1022PJ04
            read(iuimg,*)                                               1022PJ04
            read(iuimg,*)                                               1022PJ04
            do j = 1, optinp%nebinp%rgeom%natoms                        1022PJ04
               read(iuimg,4) k, ximg(i)%angcoord(3*j-2),                1022PJ04
     &                          ximg(i)%angcoord(3*j-1),                1022PJ04
     &                          ximg(i)%angcoord(3*j)                   1022PJ04
            enddo                                                       1022PJ04
            ximg(i)%aucoord = ximg(i)%angcoord/angtoau                  1022PJ04
            ximg(i)%natoms = optinp%nebinp%rgeom%natoms                 1022PJ04
            ximg(i)%atm = optinp%nebinp%rgeom%atm                       1022PJ04
         enddo                                                          1022PJ04
         close (iuimg)                                                  1022PJ04
 3    format ('NEB initial images are read from file: ', a20)           1022PJ04
 4    format(9x,i4,t20,d15.8,t40,d15.8,t60,d15.8)                       1022PJ04

c
c otherwise, obtain image from reactant and product
c

      else                                                              1022PJ04
c
c Reorientation of PRODUCT system (with the REACTANT system)
c CHEN algorithm
c
         call reorient(optinp%nebinp%rgeom%angcoord,
     &                 optinp%nebinp%pgeom%angcoord,
     &                 natoms,n3tm,optinp%nebinp%rgeom%atmmss)    
c
c Interpolation between the two initial structures
c
         call interp(optinp%nebinp, ximg)

      end if

c ************************************************************************

      fail = 0
      idorec = optinp%hrec
      nrecal = 0
      linmin = 1
      status = 0

c
c if use nebalg is TS, we should not do a line min search, since
c for the TS image, it is an uphill search. Another reason to comment
c line minimization search is that we do not know the energy objective
c function after the projection per se.
c
c     if (optinp%iop .gt. 4) then
c        linmin = 0
c     endif
c

c
c  Set up the default convergent values for the energy and derivative
c  (use the one used in GCOMP as the NEB convergence)  
c
c      if (optinp%gcomp .le. eps) then                                  0623NG05
c         gtol = 1.0d-7                                                 0623NG05
c      else                                                             0623NG05
c         gtol = optinp%gcomp                                           0623NG05
c      endif                                                            0623NG05
c      if (optinp%nebinp%nebiter .lt. 0) goto 300                       0623NG05
c
c  Get initial gradient
c
      call nebghk(optinp%nebinp, ximg, vimg, gimg,its)

c      gcomp = abs( gimg(1) )                                           0623NG05
c      do 5 i=2, ndim                                                   0623NG05
c         abgc = abs( gimg(i) )                                         0623NG05
c         if (gcomp.lt.abgc)  gcomp = abgc                              0623NG05
      abgc = 0.0d0                                                      0623NG05
      do 5 i=1, ndim                                                    0623NG05
        abgc = abgc + (gimg(i))**2                                      0623NG05
        gcomp = sqrt(abgc)                                              0623NG05
   5  continue
c
c  Make initial display of info
c
         do 10 i=1, ndim
            xxi(i) = 0.0000d0
  10     continue
         do i = 1, nimg

           call optnebdisp(0, ximg(i), vimg(i), gimg((i-1)*n3tm+1),     1111NG04
c     *                  xxi((i-1)*n3tm+1), gcomp, gtol, i)              1111NG04
     *                  xxi((i-1)*n3tm+1), gcomp, nebgtol, i)           0625NG05
         end do
c
c  Check if the geometry is already optimized.
c
      if (gcomp.le.nebgtol) then
         status = 3
         goto 300
      endif
c
c  Set initial hessian (by hhook if INITHESS is on; I otherwise)
c  (use the options available in MULTIOPT section)
c
      if (optinp%ihunit.eq.1) then
c
c can we calculate the electronic structure Hessian as a start?
c We use the block diagnol low-level electronic structure for
c each image as an start
c
         call nebhhk(optinp%nebinp,ndim,nimg,ximg,gimg,himg,
     &               optinp%constant)    
 
      elseif (optinp%ihunit.eq.0) then
 
c
c Currently, we simply use a scaled unit matrix as a start 
c
         do 21 i=1, ndim
            do 22 j=1, ndim
               himg(i,j) = 0.0d0
  22        continue
            himg(i,i) = optinp%hscale
  21     continue

      endif

c
c get the index mapping the whole Hessian to smaller one with
c six degrees of freedom fixed
c
      k = n/nimg
      do i = 1, nimg
         do j = 1, k
             indimg((i-1)*k+j) = (i-1)*n3tm + ind(j)
         end do
      end do
c
c  MAIN LOOP to perform the geometry optimization
c
      do 200 its=1, optinp%nebinp%nebiter
c
c  initialize dx0 and x0
c
         do 40 i=1, ndim
               dx0(i) = gimg(i)
  40     continue
         do i = 1, nimg
             do j = 1, n3tm
                 x0((i-1)*n3tm + j) = ximg(i)%aucoord(j)
             end do 
         end do
c         write(outfile,'(/,a,i3)') 'Initial geometry at step ', its
c         write(outfile,1018) x0
1018     format(3(1x,f10.6))
c         write(outfile,'(/,a,i3)') 'Initial gradient at step ', its
c         write(outfile,1023) dx0
1023     format(3(1x,d15.8))
c
c  Calculate Newton-Raphson step
c
         do 29 i=1, n
            tempsol(i) = -dx0(indimg(i))
            do 30 j=1, n
               luhess(i,j) = himg(indimg(i),indimg(j))
  30        continue
  29     continue

         call ludcmp(luhess, n, n, indx, d)
c
c  Write out the LU decomposed Hessian
c
c        write(outfile,'(/a)') 'LU Decomposed Hessian:'
c        write(outfile,'(6(1x,d12.5))') luhess(:n,:n)

         call lubksb(luhess, n, n, indx, tempsol)

c
c  Check solution to H*XXI = -Grad
c
         do 41 i=1, n
            prod(i) = 0.0d0
            do 42 j=1, n
               prod(i) = prod(i)+himg(indimg(i),indimg(j))*tempsol(j)   
  42        continue
  41     continue

         chksum = 0.0d0
         do 59 i=1, n
            chksum = chksum + prod(i) + gimg(indimg(i))
  59     continue

          write(outfile,'(/a,3x,d12.5)') 'Sum that should be ~0:',
     *           chksum

         do 43 i=1, ndim
            xxi(i) = 0.0000d0
  43     continue
         do 44 i=1, n
            xxi(indimg(i)) = tempsol(i)
  44     continue

c
c  Scale calculated step so that rms value not greater than scale
c
         sum = 0.0d0
         do 7 i=1, ndim
            sum = sum + xxi(i)*xxi(i)
   7     continue
         sum = sqrt(sum)
         if (sum.gt.optinp%scale)  xxi = xxi*optinp%scale/sum

         stepc = abs(xxi(1))
         mxind = 1
         do 105 i=2, ndim
            abxxi = abs(xxi(i))
            if (stepc.lt.abxxi) then
                stepc = abxxi
                mxind = i
            endif
 105     continue
c         write(outfile,'(/,a,i3)') 'XXI at step ', its
c         write(outfile,1018) xxi
c
c  Add to make sure that step not zero before send into linmn.
c
         if (stepc .eq. 0.0d0) then
            status = 4
            goto 300
         endif
c
c  ... then scale the Newton-Raphson step
c
         stepmx = optinp%scale/stepc
c
c  ... we probably cannot do the line minimization step, because
c      the NEB energy objective function after projections is 
c      actually unknown. comment out at this point
c
c        if (linmin.eq.1) then
c           call linmn(x0, xxi, ndim, fret, stepmx)
c           sum = 0.0d0
c           do 8 i=1, n3tm
c              sum = sum + xxi(i)*xxi(i)
c  8        continue
c           sum = sqrt(sum)
c           if (sum.gt.optinp%scale)  xxi = xxi*optinp%scale/sum
c           stepc = abs(xxi(mxind))
c        endif

c
c
c  Move to a new geometry and calculate new energy and gradient
c  Be careful with units - Gaussian is called with angcoord, yet the
c    optimizer operates on aucoord
c
         do i=1, nimg
             do j = 1, n3tm
                k = (i-1)*n3tm + j
                ximg(i)%aucoord(j) = x0(k) + xxi(k)
             end do
             ximg(i)%angcoord = ximg(i)%aucoord*angtoau
         end do

c         write(outfile,'(/,a)') 'Ang. Geom after scaling'
c         write(outfile,1018) ximg%angcoord(:dim)
c         write(outfile,'(/,a)') 'A.U. Geom after scaling'
c         write(outfile,1018) ximg%aucoord(:n3tm)
c
c  Get gradient and energy
c
         call nebghk(optinp%nebinp, ximg, vimg, gimg,its)
c
c         gcomp = abs(gimg(1))                                          0623NG05
c         do 130 i=2, ndim                                              0623NG05
c            abgc = abs(gimg(i))                                        0623NG05
c            if (gcomp.lt.abgc)  gcomp=abgc                             0623NG05
         abgc = 0.0d0                                                   0623NG05
         do 130 i=1, ndim                                               0623NG05
             abgc = abgc + (gimg(i))**2                                 0623NG05
             gcomp = sqrt(abgc)                                         0623NG05
 130     continue
c
c  Test for convergence
c
         if (gcomp.le.nebgtol) then
            status = 1
            goto 300
         endif
c
c  Test for magnitude of stepsize
c
         if (stepc.lt.optinp%stptol) then
            fail = 1
            write(outfile, 1350) stepc
1350        format(/,'Maximum displacement component change smaller ',
     *               'than STPTOL:',3x,d12.5)
            if (optinp%retry .eq. 0)  then
               status = 2
               goto 300
            endif
         endif

         if (fail .eq. 1) then
            write(outfile, 1375)
1375        format(/,'Switching to full Newton optimization')
            idorec = 1
            nrecal = idorec
            linmin = 0
            fail = 0
         else
            nrecal = nrecal+1
         endif
c
c  Display current step in optimization
c
         do i = 1, nimg

           call optnebdisp(its, ximg(i), vimg(i), gimg((i-1)*n3tm+1),   1111NG04
c     *                  xxi((i-1)*n3tm+1), gcomp, gtol, i)              1111NG04
     *                  xxi((i-1)*n3tm+1), gcomp, nebgtol, i)           0625NG05
         end do
c
c  Get new hessian if necessary (but not if on last step of optimization.
c
         if (nrecal.eq.idorec .and. its.ne.optinp%nebinp%nebiter) then
            nrecal = 0
            write (outfile, 1400)
 1400       format(/,'Hessian recalculated.')
            call nebhhk(optinp%nebinp,ndim,nimg,ximg,gimg,himg,
     &                  optinp%constant)    
c
c  keep frozen, note that BFGS or DFT is used to update inversed H
c
         else
            write (outfile, 1450)
1450        format(/,'Hessian kept frozen.')
         endif

 200  continue
c
c  If at this point the iterations have maxed out - print message and
c    exit routine.
c
      write (outfile, 2200)
2200  format (/5x,'NEB OPTIMIZATION FAILURE: Max iterations reached.',/)     
      ierr = 1

      return

 300  continue
c
c  Display final step in optimization and print appropriate exit message.
c

      if (status .eq. 1) then
         do i = 1, nimg

           call optnebdisp(its, ximg(i), vimg(i), gimg((i-1)*n3tm+1),   1111NG04
c     *                  xxi((i-1)*n3tm+1), gcomp, gtol, i)              1111NG04
     *                  xxi((i-1)*n3tm+1), gcomp, nebgtol, i)           0625NG05
         end do
         write (outfile, 2000)
      elseif (status .eq. 2) then
         do i = 1, nimg

           call optnebdisp(its, ximg(i), vimg(i), gimg((i-1)*n3tm+1),   1111NG04
c     *                  xxi((i-1)*n3tm+1), gcomp, gtol, i)              1111NG04
     *                  xxi((i-1)*n3tm+1), gcomp, nebgtol, i)           0625NG05
         end do
         write (outfile, 2100)
         ierr = 1
      elseif (status .eq. 3) then
         write (outfile, 2300)
      elseif (status .eq. 4) then
         write (outfile, 2400)
         ierr = 1
      endif

2000  format (/80('*'),/28x,'OPTIMIZATION SUCCESSFUL.',
     *          /80('*'),/)
2100  format (/5x,'OPTIMIZATION FAILURE: Geometry not changing.',/)
2300  format (/80('*'),/26x,'GEOMETRY ALREADY OPTIMIZED.',
     *          /80('*'),/)
2400  format (/5x,'OPTIMIZATION FAILURE: Step Size is 0.',/)

      return

9992  write (outfile,*) 'Error reading NEB image file'                  1022PJ04
      stop 'nebnr 1'                                                    1022PJ04

      end
c     
c******************************************************************************
c  NEBVB
c******************************************************************************
c     
      subroutine nebvb(optinp, ind, n, ierr)
c
c     Created:  July 2004 by Jingzhi Pu
c               Adapted from the NEBNR2 routines 
c
c     Purpose:  To perform Vanderbilt modified broyden optimization with 
c        updates of the Jacobian (J. Comput. Chem. 2003, 24, 990-996)
c
      use files, only : iuimg                                           0927NG04
      use files, only : outfile
      use input, only : cartgeom, mlopt, mlinp
c
c     use optimize, only : ener, grad, hess
c
      implicit none
c
      integer            ierr
      type (mlopt)    :: optinp
c
c Variable created to include the possibility of                        0927NG04
c  reading the neb.img file without creating it.                        0927NG04
c If filexist=true the reorient and interp subroutines                  0927NG04
c won't be called                                                       0927NG04
      logical         :: filexist                                       0927NG04

c
c bug fix, indimg should be iteger                                      1026PJ04
      integer, dimension(:), allocatable :: indimg, work                1026PJ04
      integer  idorec, nrecal, n3tm, n, ind(*), ndim, nimg, natoms   
      integer  jrank, its, mxind, fail, linmin, i, j, status, k
      double precision, dimension(:), allocatable :: xxi, x0, dx0,
     *   ddx, dxx
      double precision, dimension(:,:), allocatable :: jimgin, jimg,
     *   aimg, bimg, bimgin 
      double precision, dimension(:,:), allocatable :: himg
      double precision  gtol, gcomp, abxxi, fret, abgc,
     *    detf, stepc, stepmx, d, fac, fae, sumdg, sumxi, fad, sum

      double precision, parameter :: eps = 1.0d-14
      double precision, parameter :: angtoau = 0.5291772083d0
      double precision, parameter :: maxstep = 1.0d0
c
c w2 parameters will be read from input, now just set to a constant
c
      double precision, parameter :: omiga2 = 1.0 
c
c NEB images and total gradient to be minimized
c
      type (cartgeom), dimension(:), allocatable :: ximg
      double precision, dimension(:), allocatable :: vimg
      double precision, dimension(:), allocatable :: gimg
c
c NEB convergencia criterium set to RMS.le. 3.0d-4 (as Gaussian)        0623NG05
c
      double precision nebgtol                                          0623NG05
c
      natoms = optinp%nebinp%rgeom%natoms
      n3tm = 3*natoms
      nimg = optinp%nebinp%nimg
      ndim = n3tm*nimg
c
      nebgtol = 3.0d-4
      its = 0                                                           0623NG05
c
      filexist = .false.                                                0927NG04

      allocate (indimg(n),work(ndim))
      allocate (xxi(ndim), x0(ndim),dx0(ndim),ddx(n),dxx(n), 
     *          jimgin(n,n),jimg(n,n),aimg(n,n), bimg(n,n),
     *          bimgin(n,n),himg(ndim,ndim) )

c
c ******** NEB initialization, can be moved to a separate subroutine ****
c *****Generation of the initial set of images*****

      allocate (ximg(0:nimg+1))
      allocate (vimg(0:nimg+1))
      allocate (gimg(ndim))

c
c if we restart from a previous run, read in image from an external file
c
      inquire (file=optinp%nebinp%imgfile , exist=filexist)             1022PJ04
      if (filexist) then                                                1022PJ04
         write(outfile,3) optinp%nebinp%imgfile                         1022PJ04
         open (unit=iuimg, status='unknown',                            1022PJ04
     &         file=optinp%nebinp%imgfile, err=9992)                    1022PJ04
         do i = 0, optinp%nebinp%nimg+1                                 1022PJ04
            read(iuimg,*)                                               1022PJ04
            read(iuimg,*)                                               1022PJ04
            do j = 1, optinp%nebinp%rgeom%natoms                        1022PJ04
               read(iuimg,4) k, ximg(i)%angcoord(3*j-2),                1022PJ04
     &                          ximg(i)%angcoord(3*j-1),                1022PJ04
     &                          ximg(i)%angcoord(3*j)                   1022PJ04
            enddo                                                       1022PJ04
            ximg(i)%aucoord = ximg(i)%angcoord/angtoau                  1022PJ04
            ximg(i)%natoms = optinp%nebinp%rgeom%natoms                 1022PJ04
            ximg(i)%atm = optinp%nebinp%rgeom%atm                       1022PJ04
         enddo                                                          1022PJ04
         close (iuimg)                                                  1022PJ04
 3    format ('NEB initial images are read from file: ', a20)           1022PJ04
 4    format(9x,i4,t20,d15.8,t40,d15.8,t60,d15.8)                       1022PJ04

c
c otherwise, obtain image from reactant and product
c

      else                                                              1022PJ04
c
c Reorientation of PRODUCT system (with the REACTANT system)
c CHEN algorithm
c
         call reorient(optinp%nebinp%rgeom%angcoord,
     &                 optinp%nebinp%pgeom%angcoord,
     &                 natoms,n3tm,optinp%nebinp%rgeom%atmmss)    
c
c Interpolation between the two initial structures
c
         call interp(optinp%nebinp, ximg)

      end if

c ************************************************************************

      fail = 0
      idorec = optinp%hrec
      nrecal = 0
      linmin = 1
      status = 0

c
c if use nebalg is TS, we should not do a line min search, since
c for the TS image, it is an uphill search. Another reason to comment
c line minimization search is that we do not know the energy objective
c function after the projection per se.
c
c     if (optinp%iop .gt. 4) then
c        linmin = 0
c     endif
c

c
c  Set up the default convergent values for the energy and derivative
c  (use the one used in GCOMP as the NEB convergence)  
c
c      if (optinp%gcomp .le. eps) then                                  0623NG05
c         gtol = 1.0d-7                                                 0623NG05
c      else                                                             0623NG05
c         gtol = optinp%gcomp                                           0623NG05
c      endif                                                            0623NG05
c      if (optinp%nebinp%nebiter .lt. 0) goto 300                       0623NG05
c
c  Get initial gradient
c
      call nebghk(optinp%nebinp, ximg, vimg, gimg,its)

c      gcomp = abs( gimg(1) )                                           0623NG05
c      do 5 i=2, ndim                                                   0623NG05
c         abgc = abs( gimg(i) )                                         0623NG05
c         if (gcomp.lt.abgc)  gcomp = abgc                              0623NG05
      abgc = 0.0d0                                                      0623NG05
      do 5 i=1, ndim                                                    0623NG05
        abgc = abgc + (gimg(i))**2                                      0623NG05
        gcomp = sqrt(abgc)                                              0623NG05
   5  continue
c
c  Make initial display of info
c
         do 10 i=1, ndim
            xxi(i) = 0.0000d0
  10     continue
         do i = 1, nimg

           call optnebdisp(0, ximg(i), vimg(i), gimg((i-1)*n3tm+1),     1111NG04
c     *                  xxi((i-1)*n3tm+1), gcomp, gtol, i)              1111NG04
     *                  xxi((i-1)*n3tm+1), gcomp, nebgtol, i)           0623NG05
         end do
c
c  Check if the geometry is already optimized.
c
      if (gcomp.le.nebgtol) then
         status = 3
         goto 300
      endif
c
c  Set initial hessian (by hhook if INITHESS is on; I otherwise)
c  (use the options available in MULTIOPT section)
c
      if (optinp%ihunit.eq.1) then
c
c can we calculate the electronic structure Hessian as a start?
c We use the block diagnol low-level electronic structure for
c each image as an start
c
         call nebhhk(optinp%nebinp,ndim,nimg,ximg,gimg,himg,
     &               optinp%constant)    
 
      elseif (optinp%ihunit.eq.0) then
 
c
c Currently, we simply use a scaled unit matrix as a start 
c
         do 21 i=1, ndim
            do 22 j=1, ndim
               himg(i,j) = 0.0d0
  22        continue
            himg(i,i) = optinp%hscale
  21     continue

      endif
c
c  Get inverse of the small hessian (fix 6 or 5 cartesians for
c  each image to remove the overall translation and rotation)
c
      k = n/nimg
      do i = 1, nimg
         do j = 1, k
             indimg((i-1)*k+j) = (i-1)*n3tm + ind(j)
         end do
      end do

      do 23 i=1, n
         do 24 j=1, n
            jimg(i,j) = himg(indimg(i),indimg(j))
            jimgin(i,j) = jimg(i,j)
  24     continue
  23  continue

      write(outfile,*) '--- Initial Jacobian ---'
      write(outfile,1027) jimg(:n,:n)

c
c     call mxlneq( jimgin(:n,:n),n,n,detf,jrank,eps,work,0,n )
c
      call rminv(jimg, jimgin,n)

      write(outfile,*) '--- Initial Inverse Jacobian ---'
      write(outfile,1027) jimgin(:n,:n)
1027  format(6(1x,d12.5))

c
c  MAIN LOOP to perform the geometry optimization
c
      do 200 its=1, optinp%nebinp%nebiter
c
c  initialize dx0 and x0
c
         do 40 i=1, ndim
               dx0(i) = gimg(i)
  40     continue
         do i = 1, nimg
             do j = 1, n3tm
                 x0((i-1)*n3tm + j) = ximg(i)%aucoord(j)
             end do 
         end do
c         write(outfile,'(/,a,i3)') 'Initial geometry at step ', its
c         write(outfile,1018) x0
1018     format(3(1x,f10.6))
c         write(outfile,'(/,a,i3)') 'Initial gradient at step ', its
c         write(outfile,1023) dx0
1023     format(3(1x,d15.8))
c
c  Calculate Newton-Raphson step
c
         do 29 i=1, ndim
            xxi(i) = 0.0d0
  29     continue
         do 30 i=1, n
            do 31 j=1, n
               xxi(indimg(i)) = xxi(indimg(i)) 
     &                          - jimgin(i,j)*dx0(indimg(j))
  31        continue
  30     continue
c
c  Move to a new geometry and calculate new energy and gradient
c  Be careful with units - Gaussian is called with angcoord, yet the
c    optimizer operates on aucoord
c
         do i=1, nimg
             do j = 1, n3tm
                k = (i-1)*n3tm + j
                ximg(i)%aucoord(j) = x0(k) + xxi(k)
             end do
             ximg(i)%angcoord = ximg(i)%aucoord*angtoau
         end do
c
c  Get gradient and energy
c
         call nebghk(optinp%nebinp, ximg, vimg, gimg,its)
c
c         gcomp = abs(gimg(1))                                          0623NG05
c         do 130 i=2, ndim                                              0623NG05
c            abgc = abs(gimg(i))                                        0623NG05
c            if (gcomp.lt.abgc)  gcomp=abgc                             0623NG05
         abgc = 0.0d0                                                   0623NG05
         do 130 i=1, ndim                                               0623NG05
             abgc = abgc + (gimg(i))**2                                 0623NG05
             gcomp = sqrt(abgc)                                         0623NG05
 130     continue
c
c  Test for convergence
c
         if (gcomp.le.nebgtol) then
            status = 1
            goto 300
         endif
c
c test step change
c
         stepc = abs(xxi(1))
         mxind = 1
         do 105 i=2, ndim
            abxxi = abs(xxi(i))
            if (stepc.lt.abxxi) then
                stepc = abxxi
                mxind = i
            endif
 105     continue
c         write(outfile,'(/,a,i3)') 'XXI at step ', its
c         write(outfile,1018) xxi
c
c  Add to make sure that step not zero before send into linmn.
c
         if (stepc .eq. 0.0d0) then
            status = 4
            goto 300
         endif
c
c  Test for magnitude of stepsize
c
         if (stepc.lt.optinp%stptol) then
            fail = 1
            write(outfile, 1350) stepc
1350        format(/,'Maximum displacement component change smaller ',
     *               'than STPTOL:',3x,d12.5)
            if (optinp%retry .eq. 0)  then
               status = 2
               goto 300
            endif
         endif

         if (fail .eq. 1) then
            write(outfile, 1375)
1375        format(/,'Switching to full Newton optimization')
            idorec = 1
            nrecal = idorec
            linmin = 0
            fail = 0
         else
            nrecal = nrecal+1
         endif
c
c  Display current step in optimization
c
         do i = 1, nimg

           call optnebdisp(its, ximg(i), vimg(i), gimg((i-1)*n3tm+1),   1111NG04
c     *                  xxi((i-1)*n3tm+1), gcomp, gtol, i)              1111NG04
     *                  xxi((i-1)*n3tm+1), gcomp, nebgtol, i)           0623NG05
         end do
c
c  Get new Jacobian 
c

c
c dP = (Pi+1 - Pi)/|Pi+1 - Pi)|
c
          sum = 0.0d0
          do i = 1, n
             dxx(i) = xxi(indimg(i))
             sum = sum + dxx(i)*dxx(i)
          end do
          sum = sqrt(sum)
          do i = 1, n
             dxx(i)=dxx(i)/sum
          end do

c        
c dG = (Gi+1 - Gi)/|Pi+1 - Pi)|
c           
          do i = 1, n
             ddx(i) = (gimg(indimg(i))-dx0(indimg(i)))/sum
          end do

          if (its .eq. 1 .or. nrecal.eq.idorec .and. 
     &        its.ne.optinp%nebinp%nebiter ) then
              nrecal = 0
              write (outfile, 1400)
 1400         format(/,'Jacobian update restarts.')
c
c inital A matrix
c
             do i = 1, n
                do j = 1, n
                   aimg(i,j) = omiga2*jimg(i,j) + omiga2*ddx(i)*dxx(j)
                end do
             end do
c
c initial B matrix
c
             do i = 1, n
                do j = 1, n
                   bimg(i,j) = omiga2*dxx(i)*dxx(j)
                   bimgin(i,j) = bimg(i,j)
                end do
                bimg(i,i) = bimg(i,i) + omiga2
                bimgin(i,i) = bimg(i,i)
             end do

          else 
c
c update A matrix 
c
             do i = 1, n
                do j = 1, n
                   aimg(i,j) = aimg(i,j) + omiga2*ddx(i)*dxx(j)   
                end do
             end do
c
c update the B matrix 
c
             do i = 1, n
                do j = 1, n
                  bimg(i,j) = bimg(i,j) + omiga2 * dxx(i) * dxx(j)  
                  bimgin(i,j) = bimg(i,j) 
                end do
             end do

         end if
c
c compute B inverse 
c
c        call mxlneq(bimgin(:n,:n),n,n,detf,jrank,eps,work,0,n )
c
         call rminv(bimg, bimgin, n)
c
c compute Jacobian for next iteration
c
         do i = 1, n 
             do j = 1, n
                 jimg(i,j) = 0.0d0
                 do k = 1, n
                    jimg(i,j) = jimg(i,j) + aimg(i,k)*bimgin(k,j)
                 end do
                 jimgin(i,j) = jimg(i,j)
             end do
         end do

c
c        call mxlneq( jimgin(:n,:n),n,n,detf,jrank,eps,work,0,n )
c
         call rminv(jimg, jimgin,n)
 
 200  continue
c
c  If at this point the iterations have maxed out - print message and
c    exit routine.
c
      write (outfile, 2200)
2200  format (/5x,'NEB OPTIMIZATION FAILURE: Max iterations reached.',/)     
      ierr = 1

      return

 300  continue
c
c  Display final step in optimization and print appropriate exit message.
c

      if (status .eq. 1) then
         do i = 1, nimg

           call optnebdisp(its, ximg(i), vimg(i), gimg((i-1)*n3tm+1),   1111NG04
c     *                  xxi((i-1)*n3tm+1), gcomp, gtol, i)              1111NG04
     *                  xxi((i-1)*n3tm+1), gcomp, nebgtol, i)           0623NG05
         end do
         write (outfile, 2000)
      elseif (status .eq. 2) then
         do i = 1, nimg

           call optnebdisp(its, ximg(i), vimg(i), gimg((i-1)*n3tm+1),   1111NG04
c     *                  xxi((i-1)*n3tm+1), gcomp, gtol, i)              1111NG04
     *                  xxi((i-1)*n3tm+1), gcomp, nebgtol, i)           0623NG05
         end do
         write (outfile, 2100)
         ierr = 1
      elseif (status .eq. 3) then
         write (outfile, 2300)
      elseif (status .eq. 4) then
         write (outfile, 2400)
         ierr = 1
      endif

2000  format (/80('*'),/28x,'OPTIMIZATION SUCCESSFUL.',
     *          /80('*'),/)
2100  format (/5x,'OPTIMIZATION FAILURE: Geometry not changing.',/)
2300  format (/80('*'),/26x,'GEOMETRY ALREADY OPTIMIZED.',
     *          /80('*'),/)
2400  format (/5x,'OPTIMIZATION FAILURE: Step Size is 0.',/)

      return

9992  write (outfile,*) 'Error reading NEB image file'                  1022PJ04
      stop 'nebnr2 1'                                                   1022PJ04

      end

c
c*******************************************************************
c RMINV
c*******************************************************************
c A = inv(B)
c
      subroutine rminv(b, a, n)
c    
      implicit none
c
      integer n
      double precision b(n,n), a(n,n)
c
      integer i,j,k
      double precision x
c
      do i = 1, n
         do  j = 1, n
            a(i,j) = b(i,j)
         end do
      end do
c
      do i = 1, n
         x = a(i,i)
         a(i,i) = 1.0d0

         do j = 1, n
            a(j,i) = a(j,i)/x
         end do

         do k = 1, n   
             if (k .ne. i) then
                x = a(i,k)
                a(i,k) = 0.0d0
                do j = 1, n
                  a(j,k) = a(j,k) - a(j,i)*x
                end do
             end if
         end do
      end do

      return
      end 

      

        
