c
c
c     ##############################################################
c     ##  COPYRIGHT (C) 1997 by Rohit Pappu & Jay William Ponder  ##
c     ##                   All Rights Reserved                    ##
c     ##############################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  program demrigid  --  diffusion equation for rigid bodies  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "demrigid" implements the diffusion equation method via energy
c     minimization on a series of smoothed potential energy surfaces
c     in rigid body space
c
c     literature reference :
c
c     J. Kostrowicki and H. A. Scheraga, "Application of the Diffusion
c     Equation Method for Global Optimization to Oligopeptides", Journal
c     of Physical Chemistry, 96, 7442-7449 (1992)
c
c     S. Nakamura, H. Hirose, M. Ikeguchi and J. Doi, "Conformational
c     Energy Minimization Using a Two-Stage Method", Journal of Physical
c     Chemistry, 99, 8374-8378 (1995)
c
c
      program demrigid
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'files.i'
      include 'group.i'
      include 'iounit.i'
      include 'math.i'
      include 'minima.i'
      include 'molcul.i'
      include 'output.i'
      include 'refer.i'
      include 'rigid.i'
      include 'warp.i'
      integer i,j,k,ixyz
      integer nvar,npoint,neigen
      integer lext,freeunit
      real*8 minimum,grdmin,rms
      real*8 demrgd1,deform0
      real*8 ratio,sigmoid
      real*8 xx(maxvar)
      character*1 answer
      character*7 ext
      character*60 coordfile
      character*80 string
      logical exist,use_doi
      external demrgd1,writeout
c
c     set up the structure and mechanics calculation
c
      call initial
      call getxyz
      call mechanic
c
c     get rigid body coordinates and save the Cartesian coordinates
c
      call orient
      call makeref
c
c     set maximum deformation value and the coordinate type
c
      deform0 = deform
      coordtype = 'none'
c
c     get the number of points along the deformation schedule
c
      npoint = -1
      call nextarg (string,exist)
      if (exist)  read (string,*,err=10,end=10)  npoint
   10 continue
      if (npoint .le. 0) then
         write (iout,20)
   20    format(/,' Enter the Number of Steps for the DEM Schedule',
     &             ' [100] :  ',$)
         read (input,30)  npoint
   30    format (i10)
         if (npoint .le. 0)  npoint = 100
      end if
c
c     decide whether to use the Doi local search procedure
c
      use_doi = .false.
      call nextarg (answer,exist)
      if (.not. exist) then
         write (iout,40)
   40    format(/,' Use a Local Search During DEM Minimization',
     &             ' [N] :  ',$)
         read (input,50)  answer
   50    format (a1)
      end if
      call upcase (answer)
      if (answer .eq. 'Y')  use_doi = .true.
c
c     get the number of eigenvectors to use for the local search
c
      if (use_doi) then
         neigen = -1
         call nextarg (string,exist)
         if (exist)  read (string,*,err=60,end=60)  neigen
   60    continue
         if (neigen .le. 0) then
            write (iout,70)
   70       format(/,' Enter the Number Search Directions for Local',
     &                ' Search [5] :  ',$)
            read (input,80)  neigen
   80       format (i10)
            if (neigen .le. 0)  neigen = 5
         end if
      end if
c
c     get the termination criterion as RMS gradient per atom
c
      grdmin = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=90,end=90)  grdmin
   90 continue
      if (grdmin .le. 0.0d0) then
         write (iout,100)
  100    format (/,' Enter RMS Gradient per Rigid Body Criterion',
     &              ' [0.0001] :  ',$)
         read (input,110)  grdmin
  110    format (f20.0)
      end if
      if (grdmin .le. 0.0d0)  grdmin = 0.0001d0
c
c     perform DEM iteration by looping over smoothed surfaces
c
      do k = 0, 2*npoint
         ratio = 1.0d0 - dble(abs(npoint-k))/dble(npoint)
         if (nmol .eq. 1) then
            deform = deform0 * ratio**3
         else
            deform = deform0 * sigmoid (12.0d0,ratio)
         end if
c
c     transfer rigid body coordinates to optimization parameters
c
         nvar = 0
         do i = 1, ngrp
            do j = 1, 6
               nvar = nvar + 1
               xx(nvar) = rbc(j,i)
            end do
         end do
c
c     make the call to the variable metric optimization routine
c
         iprint = 1
         call vmetric (nvar,xx,minimum,grdmin,demrgd1,writeout)
c
c     transfer optimization parameters to rigid body coordinates
c
         nvar = 0
         do i = 1, ngrp
            do j = 1, 6
               nvar = nvar + 1
               rbc(j,i) = xx(nvar)
            end do
         end do
c
c     use Doi's local search to explore near the DEM minimum
c
         if (use_doi) then
            if (deform.le.5.0d0 .and. k.ge.npoint)
     &         call doirigid (neigen,minimum)
         end if
c
c     write out final energy function value and smoothing level
c
         write (iout,120)  minimum,deform
  120    format (/,' Final Function Value and Deformation :',2f15.4)
c
c     get Cartesian coordinates and superimpose on reference
c
         call rigidxyz
         if (igrp(1,1).eq.1 .and. igrp(2,ngrp).eq.n)
     &      call impose (n,xref,yref,zref,n,x,y,z,rms)
c
c     write the coordinates of the current minimum to a file
c
         lext = 3
         call numeral (k,ext,lext)
         ixyz = freeunit ()
         coordfile = filename(1:leng)//'.'//ext(1:lext)
         call version (coordfile,'new')
         open (unit=ixyz,file=coordfile,status='new')
         call prtxyz (ixyz)
         close (unit=ixyz)
      end do
      end
c
c
c     ############################################################
c     ##                                                        ##
c     ##  function demrgd1  --  energy/gradient values for DEM  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "demrgd1" is a service routine that computes the energy and
c     gradient during DEM global optimization over rigid bodies
c
c
      function demrgd1 (xx,g)
      implicit none
      include 'sizes.i'
      include 'group.i'
      include 'math.i'
      include 'rigid.i'
      integer i,j,nvar
      real*8 demrgd1,e
      real*8 xx(maxvar),g(maxvar)
      real*8 derivs(6,maxgrp)
c
c
c     translate optimization variables to rigid body coordinates
c
      nvar = 0
      do i = 1, ngrp
         do j = 1, 6
            nvar = nvar + 1
            rbc(j,i) = xx(nvar)
         end do
      end do
c
c     compute and store the energy and gradient
c
      call rigidxyz
      call gradrgd (e,derivs)
      demrgd1 = e
c
c     translate rigid body gradient to optimization gradient
c
      nvar = 0
      do i = 1, ngrp
         do j = 1, 6
            nvar = nvar + 1
            g(nvar) = derivs(j,i)
         end do
      end do
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine doirigid  --  local search for rigid body DEM  ##
c     ##                                                            ##
c     ################################################################
c
c
      subroutine doirigid (neigen,minimum)
      implicit none
      include 'sizes.i'
      include 'group.i'
      include 'iounit.i'
      include 'rigid.i'
      integer maxrgd
      parameter (maxrgd=6*maxgrp)
      integer i,j,k,neigen,ndoi,nvar,nsearch
      real*8 minimum,minref,minbest
      real*8 eps,step(maxrgd)
      real*8 rbref(6,maxgrp),rbbest(6,maxgrp)
      real*8 eigen(maxrgd),vects(maxrgd,maxrgd)
      logical done
c
c
c     set parameters related to the local search procedure
c
      done = .false.
      eps = 0.0001d0
      minref = minimum
      minbest = minimum
      ndoi = 0
      nvar = 6 * ngrp
      do i = 1, ngrp
         do j = 1, 6
            rbref(j,i) = rbc(j,i)
         end do
      end do
c
c     find local minimum along each of the steepest directions
c
      dowhile (.not. done)
         ndoi = ndoi + 1
         write (iout,10)  ndoi,minref
   10    format (/,' Normal Mode Search :',8x,'Iteration',i4,
     &              5x,'Energy',f12.4,/)
         call rigidxyz
         call eigenrgd (eigen,vects)
c
c     search both directions along each eigenvector in turn
c
         nsearch = 0
         do i = 1, neigen
            do k = 1, nvar
               step(k) = vects(k,nvar-i+1)
            end do
            do k = 1, ngrp
               do j = 1, 6
                  rbc(j,k) = rbref(j,k)
               end do
            end do
            nsearch = nsearch + 1
            call climbrgd (nsearch,minimum,step)
            if (minimum .lt. minbest) then
               minbest = minimum
               do k = 1, ngrp
                  do j = 1, 6
                     rbbest(j,k) = rbc(j,k)
                  end do
               end do
            end if
            do k = 1, nvar
               step(k) = -vects(k,nvar-i+1)
            end do
            do k = 1, ngrp
               do j = 1, 6
                  rbc(j,k) = rbref(j,k)
               end do
            end do
            nsearch = nsearch + 1
            call climbrgd (nsearch,minimum,step)
            if (minimum .lt. minbest) then
               minbest = minimum
               do k = 1, ngrp
                  do j = 1, 6
                     rbbest(j,k) = rbc(j,k)
                  end do
               end do
            end if
         end do
c
c     check for convergence of the local search procedure
c
         if (minbest .lt. minref-eps) then
            done = .false.
            minref = minbest
            do k = 1, ngrp
               do j = 1, 6
                  rbref(j,k) = rbbest(j,k)
               end do
            end do
         else
            done = .true.
            minimum = minref
            do k = 1, ngrp
               do j = 1, 6
                  rbc(j,k) = rbref(j,k)
               end do
            end do
         end if
      end do
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine eigenrgd  --  rigid body Hessian eigenvectors  ##
c     ##                                                            ##
c     ################################################################
c
c
      subroutine eigenrgd (eigen,vects)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'group.i'
      integer maxrgd
      parameter (maxrgd=6*maxgrp)
      integer i,j,ihess,nvar
      real*8 hrigid(maxrgd,maxrgd),matrix((maxrgd+1)*maxrgd/2)
      real*8 a(maxrgd+1),b(maxrgd+1),p(maxrgd+1),ta(maxrgd+1)
      real*8 w(maxrgd+1),tb(maxrgd+1),ty(maxrgd+1)
      real*8 vnorm,eigen(maxrgd),vects(maxrgd,maxrgd)
c
c
c     compute the Hessian for rigid body motion
c
      call hessrgd ('full',hrigid)
c
c     place Hessian elements into triangular form
c
      nvar = 6 * ngrp
      ihess = 0
      do i = 1, nvar
         do j = i, nvar
            ihess = ihess + 1
            matrix(ihess) = hrigid(i,j)
         end do
      end do
c
c     diagonalize the Hessian to obtain eigenvalues
c
      call diagq (nvar,maxrgd,nvar,matrix,eigen,vects,
     &                     a,b,p,w,ta,tb,ty)
c
c     normalize the rigid body Hessian eigenvectors
c
      do i = 1, nvar
         vnorm = 0.0d0
         do j = 1, nvar
            vnorm = vnorm + vects(j,i)**2
         end do
         vnorm = sqrt(vnorm)
         do j = 1, nvar
            vects(j,i) = vects(j,i) / vnorm
         end do
      end do
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine climbrgd  --  minimum from a DEM local search  ##
c     ##                                                            ##
c     ################################################################
c
c
      subroutine climbrgd (nsearch,minimum,step)
      implicit none
      include 'sizes.i'
      include 'group.i'
      include 'iounit.i'
      include 'math.i'
      include 'rigid.i'
      integer maxrgd,maxstep
      parameter (maxrgd=6*maxgrp)
      parameter (maxstep=500)
      integer i,j,nvar,kstep,nstep,nsearch
      real*8 minimum,big,energy,size
      real*8 step(maxrgd),estep(0:maxstep)
      logical done
c
c
c     set the maximum number of steps and the step size
c
      done = .false.
      big = 100000.0d0
      minimum = big
      kstep = 0
      nstep = 65
c     size = 0.1d0
      size = 1.0d0
      nvar = 6 * ngrp
      do i = 1, nvar
         step(i) = size * step(i)
      end do
c
c     scan the search direction for a minimization candidate
c
      dowhile (.not. done)
         if (kstep .ne. 0) then
            nvar = 0
            do i = 1, ngrp
               do j = 1, 6
                  nvar = nvar + 1
                  rbc(j,i) = rbc(j,i) + step(nvar)
               end do
            end do
         end if
         call rigidxyz
         estep(kstep) = energy ()
         if (kstep.ge.2 .and. estep(kstep).le.10000.0d0) then
            if (estep(kstep) .lt. estep(kstep-2) .and.
     &          estep(kstep-1) .lt. estep(kstep-2)) then
               done = .true.
               nvar = 0
               do i = 1, ngrp
                  do j = 1, 6
                     nvar = nvar + 1
                     rbc(j,i) = rbc(j,i) - step(nvar)
                  end do
               end do
               call rigidxyz
               call localrgd (minimum)
               if (minimum .ge. -big) then
                  write (iout,10)  nsearch,kstep-1,minimum
   10             format (4x,'Search Direction',i4,10x,'Step',
     &                       i4,11x,f12.4)
               else
                  minimum = big
                  write (iout,20)  nsearch
   20             format (4x,'Search Direction',i4,35x,'------')
               end if
            end if
         end if
         if (kstep.ge.nstep .and. .not.done) then
            done = .true.
            write (iout,30)  nsearch
   30       format (4x,'Search Direction',i4,35x,'------')
         end if
         kstep = kstep + 1
      end do
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine localrgd  --  DEM local search optimization  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "localrgd" is during the the DEM local search procedure
c     to perform a rigid body energy minimization
c
c
      subroutine localrgd (minimum)
      implicit none
      include 'sizes.i'
      include 'inform.i'
      include 'group.i'
      include 'minima.i'
      include 'rigid.i'
      integer i,j,nvar,oldprt
      real*8 minimum,grdmin
      real*8 demrgd1,xx(maxvar)
      logical oldverb
      external demrgd1,writeout
c
c
c     transfer rigid body coordinates to optimization parameters
c
      nvar = 0
      do i = 1, ngrp
         do j = 1, 6
            nvar = nvar + 1
            xx(nvar) = rbc(j,i)
         end do
      end do
c
c     make the call to the optimization routine
c
      grdmin = 0.0001d0
      oldverb = verbose
      oldprt = iprint
      verbose = .false.
      iprint = 0
      call vmetric (nvar,xx,minimum,grdmin,demrgd1,writeout)
      verbose = oldverb
      iprint = oldprt
c
c     transfer optimization parameters to rigid body coordinates
c
      nvar = 0
      do i = 1, ngrp
         do j = 1, 6
            nvar = nvar + 1
            rbc(j,i) = xx(nvar)
         end do
      end do
      return
      end
