c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  program testhess  --  Hessian matrix test; cart. version  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "testhess" computes and compares the analytical and numerical
c     Hessian matrices of the potential energy function with respect
c     to Cartesian coordinates
c
c
      program testhess
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'files.i'
      include 'hescut.i'
      include 'iounit.i'
      include 'usage.i'
      integer maxnum
      parameter (maxnum=120)
      integer i,j,k,m,ihes,ii,jj,index,freeunit
      integer hinit(3,maxatm),hstop(3,maxatm)
      integer hindex(maxhess)
      real*8 h(maxhess),hdiag(3,maxatm)
      real*8 g(3,maxatm),g0(3,maxatm)
      real*8 energy,e,old,eps,eps0,delta,sum
      real*8 nhess(3,maxnum,3,maxnum)
      character*1 answer,axis(3)
      character*60 hessfile
      character*80 string
      logical doanalyt,donumer,dograd,dofull
      logical exist,query,identical
      external energy
      data axis  / 'X','Y','Z' /
c
c
c     set up the structure and mechanics calculation
c
      call initial
      call getxyz
      call mechanic
c
c     decide whether to do an analytical Hessian calculation
c
      doanalyt = .true.
      call nextarg (answer,exist)
      if (.not. exist) then
         write (iout,10)
   10    format (/,' Compute Analytical Hessian Matrix [Y] :  ',$)
         read (input,20)  answer
   20    format (a1)
      end if
      call upcase (answer)
      if (answer .eq. 'N')  doanalyt = .false.
c
c     decide whether to do a numerical Hessian calculation
c
      donumer = .false.
      if (n .le. maxnum) then
         donumer = .true.
         call nextarg (answer,exist)
         if (.not. exist) then
            write (iout,30)
   30       format (/,' Compute Numerical Hessian Matrix [Y] :   ',$)
            read (input,40)  answer
   40       format (a1)
         end if
         call upcase (answer)
         if (answer .eq. 'N')  donumer = .false.
      end if
c
c     get numerical Hessian from either gradient or energy
c
      if (donumer) then
         dograd = .true.
         call nextarg (answer,exist)
         if (.not. exist) then
            write (iout,50)
   50       format (/,' Numerical Hessian from Gradient',
     &                 ' or Function [G] :  ',$)
            read (input,60)  answer
   60       format (a1)
         end if
         call upcase (answer)
         if (answer .eq. 'F')  dograd = .false.
c
c     get the stepsize for numerical Hessian calculation
c
         eps = -1.0d0
         eps0 = 1.0d-5
         if (dograd)  eps0 = 1.0d-6
         query = .true.
         call nextarg (string,exist)
         if (exist) then
            read (string,*,err=70,end=70)  eps
            query = .false.
         end if
   70    continue
         if (query) then
            write (iout,80)  eps0
   80       format (/,' Enter a Numerical Stepsize [',d7.1,
     &                 ' Ang] :  ',$)
            read (input,90)  eps
   90       format (f20.0)
         end if
         if (eps .eq. 0.0d0)  eps = eps0
      end if
c
c     decide whether to output results by Hessian component
c
      dofull = .false.
      if (n.le.20 .and. donumer) then
         call nextarg (answer,exist)
         if (.not. exist) then
            write (iout,100)
  100       format (/,' List individual Hessian Components [N] :   ',$)
            read (input,110)  answer
  110       format (a1)
         end if
         call upcase (answer)
         if (answer .eq. 'Y')  dofull = .true.
      end if
c
c     get the analytical Hessian matrix elements
c
      identical = .true.
      if (doanalyt) then
         hesscut = 0.0d0
         call hessian (h,hinit,hstop,hindex,hdiag)
      end if
c
c     get the two-sided numerical Hessian matrix elements
c
      do i = 1, n
         if (donumer .and. use(i)) then
            old = x(i)
            x(i) = x(i) - 0.5d0*eps
            if (dograd) then
               call gradient (e,g)
            else
               call numgrad (energy,g,eps)
            end if
            do k = 1, n
               do j = 1, 3
                  g0(j,k) = g(j,k)
               end do
            end do
            x(i) = x(i) + eps
            if (dograd) then
               call gradient (e,g)
            else
               call numgrad (energy,g,eps)
            end if
            x(i) = old
            do k = 1, n
               do j = 1, 3
                  nhess(j,k,1,i) = (g(j,k) - g0(j,k)) / eps
               end do
            end do
            old = y(i)
            y(i) = y(i) - 0.5d0*eps
            if (dograd) then
               call gradient (e,g)
            else
               call numgrad (energy,g,eps)
            end if
            do k = 1, n
               do j = 1, 3
                  g0(j,k) = g(j,k)
               end do
            end do
            y(i) = y(i) + eps
            if (dograd) then
               call gradient (e,g)
            else
               call numgrad (energy,g,eps)
            end if
            y(i) = old
            do k = 1, n
               do j = 1, 3
                  nhess(j,k,2,i) = (g(j,k) - g0(j,k)) / eps
               end do
            end do
            old = z(i)
            z(i) = z(i) - 0.5d0*eps
            if (dograd) then
               call gradient (e,g)
            else
               call numgrad (energy,g,eps)
            end if
            do k = 1, n
               do j = 1, 3
                  g0(j,k) = g(j,k)
               end do
            end do
            z(i) = z(i) + eps
            if (dograd) then
               call gradient (e,g)
            else
               call numgrad (energy,g,eps)
            end if
            z(i) = old
            do k = 1, n
               do j = 1, 3
                  nhess(j,k,3,i) = (g(j,k) - g0(j,k)) / eps
               end do
            end do
         end if
c
c     compare the analytical and numerical Hessian components
c
         if (doanalyt .and. donumer) then
            do j = 1, 3
               delta = abs(hdiag(j,i)-nhess(j,i,j,i))
               if (delta .gt. 1.0d-4) then
                  if (identical) then
                     identical = .false.
                     write (iout,120)
  120                format (/,' Differences between Analytical',
     &                          ' and Numerical Hessian Elements :',
     &                       //,3x,' First Atom',5x,'Second Atom',
     &                          10x,'Analytical',6x,'Numerical',/)
                  end if
                  write (iout,130)  i,axis(j),i,axis(j),
     &                              hdiag(j,i),nhess(j,i,j,i)
  130             format (3x,i6,' (',a1,') ',5x,i6,
     &                       ' (', a1,') ',4x,2f15.4)
               end if
               do k = hinit(j,i), hstop(j,i)
                  index = hindex(k)
                  jj = mod(index,3)
                  if (jj .eq. 0)  jj = 3
                  ii = (index+2) / 3
                  delta = abs(h(k)-nhess(jj,ii,j,i))
                  if (delta .gt. 1.0d-4) then
                     if (identical) then
                        identical = .false.
                        write (iout,140)
  140                   format (/,' Differences between Analytical',
     &                             ' and Numerical Hessian Elements :',
     &                          //,3x,' First Atom',5x,'Second Atom',
     &                             10x,'Analytical',6x,'Numerical',/)
                     end if
                     write (iout,150)  i,axis(j),ii,axis(jj),
     &                                 h(k),nhess(jj,ii,j,i)
  150                format (3x,i6,' (',a1,') ',5x,i6,
     &                          ' (', a1,') ',4x,2f15.4)
                  end if
               end do
            end do
         end if
      end do
c
c     success if the analytical and numerical elements are the same
c
      if (doanalyt .and. donumer) then
         if (identical) then
            write (iout,160)
  160       format (/,' Analytical and Numerical Hessian Elements',
     &              ' are Identical')
         end if
      end if
c
c     write out the Hessian trace as sum of diagonal elements
c
      if (doanalyt) then
         sum = 0.0d0
         do i = 1, n
            do j = 1, 3
               sum = sum + hdiag(j,i)
            end do
         end do
         write (iout,170)  sum
  170    format (/,' Sum of Diagonal Hessian Elements :',6x,f15.4)
      end if
c
c     write out the full matrix of numerical Hessian elements
c
      if (dofull .and. donumer) then
         do i = 1, n
            do k = 1, n
               write (iout,180)  i,k
  180          format (/,' 3x3 Hessian Block for Atoms :',2i7,/)
               do j = 1, 3
                  write (iout,190)  (nhess(m,i,j,k),m=1,3)
  190             format (' Numer',5x,3f15.4)
               end do
            end do
         end do
      end if
c
c     write out the full matrix of analytical Hessian elements
c
      if (doanalyt .and. .not.donumer) then
         ihes = freeunit ()
         hessfile = filename(1:leng)//'.hes'
         call version (hessfile,'new')
         open (unit=ihes,file=hessfile,status='new')
         write (iout,200)  hessfile
  200    format (/,' Hessian Matrix written to File :  ',a40)
         write (ihes,210)
  210    format (/,' Diagonal Hessian Elements  (3 per Atom)',/)
         write (ihes,220)  ((hdiag(j,i),j=1,3),i=1,n)
  220    format (6f12.4)
         do i = 1, n
            do j = 1, 3
               if (hinit(j,i) .le. hstop(j,i)) then
                  write (ihes,230)  i,axis(j)
  230             format (/,' Off-diagonal Hessian Elements for Atom',
     &                       i6,1x,a1,/)
                  write (ihes,240)  (h(k),k=hinit(j,i),hstop(j,i))
  240             format (6f12.4)
               end if
            end do
         end do
         close (unit=ihes)
      end if
      end
