c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine lmqn  --  conjugate gradient optimization  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "lmqn" is a gradient optimization routine which implements
c     steepest descent, Fletcher-Reeves CG, Polak-Ribiere CG,
c     Hestenes-Stiefel CG, Powell-Beale CG with restarts, and a
c     limited memory BFGS quasi-Newton method
c
c     literature references :
c
c     David G. Luenberger, "Linear and Nonlinear Programming,
c     2nd Edition", Addison-Wesley, Reading, MA, 1984; see in
c     particular section 9-7
c
c     Stephen G. Nash and Ariela Sofer, "Linear and Nonlinear
c     Programming", McGraw-Hill, New York, 1996; see chapter 12
c
c     parameters used in the main iteration :
c
c     nvar     number of parameters in the objective function
c     method   steepest descent, FRCG, PRCG, HSCG, Powell or LMQN
c     fctmin   normal exit if function gets less than
c     grdmin   normal exit if gradient norm gets less than
c     maxiter  error return if number of iterations exceeds
c     period   restart at least every period iterations
c     iprint   print iteration results every iprint iterations
c     iwrite   call user-supplied output every iwrite iterations
c     fast     steepest descent while function decrease exceeds
c     slow     restart if relative function decrease drops below
c     epsln    error if total move is less than
c     scale    factor by which actual function has been multiplied
c     rms      factor to convert grad norm and movement to rms
c     minimum  final value of the objective function
c     ncalls   number of function/gradient (fgvalue) calls
c     niter    number of conjugate gradient iterations performed
c     status   string containing informative termination message
c
c     parameters used in the line search :
c
c     cappa    reduction in projected gradient for termination
c     stpmin   minimum allowed line search step size
c     stpmax   maximum allowed line search step size
c     angmax   maximum angle between search and -grad directions
c     intmax   maximum number of interpolations in line search
c
c     vectors stored by the routine :
c
c     x        current parameter values
c     x_old    previous parameter values
c     g        current gradient vector
c     g_old    previous gradient vector
c     s        current minus previous parameter values
c     d        current minus previous gradient values
c     p        conjugate direction search vector
c
c     requried external routines :
c
c     fgvalue    function to evaluate function and gradient values
c     writeout   subroutine to write out info about current status
c
c
      subroutine lmqn (nvar,x,minimum,grdmin,fgvalue,writeout)
      implicit none
      include 'sizes.i'
      include 'iounit.i'
      include 'keys.i'
      include 'linmin.i'
      include 'math.i'
      include 'minima.i'
      include 'output.i'
      include 'potent.i'
      include 'scales.i'
      include 'solute.i'
      integer i,ncalls,nerror,next,ipow
      integer nvar,niter,period,nstart
      real*8 grdmin,fast,slow,epsln
      real*8 f,f_old,f_new,f_move
      real*8 rms,beta,gamma,angle,ratio
      real*8 x_move,g_norm,g_rms
      real*8 minimum,fgvalue,gg,gg_old
      real*8 sg,dg,dp,sd,dd,dtg,dtpt
      real*8 x(maxvar),g(maxvar)
      real*8 x_old(maxvar),g_old(maxvar)
      real*8 p(maxvar),s(maxvar),d(maxvar)
      real*8 pt(maxvar),dt(maxvar)
      character*3 method
      character*9 blank,status
      character*20 keyword
      character*80 record
      logical restart,terminate
      external fgvalue,writeout
c
c
c     initialize some values to be used below
c
      if (nvar .gt. maxvar) then
         write (iout,10)
   10    format (' LMQN  --  Too many Parameters,',
     &           ' Increase value of MAXVAR')
         return
      end if
      ncalls = 0
      rms = sqrt(dble(nvar))
      if (coordtype .eq. 'cartesian') then
         rms = rms / sqrt(3.0d0)
      else if (coordtype .eq. 'rigidbody') then
         rms = rms / sqrt(6.0d0)
      end if
      blank = '         '
      status = blank
      method = 'mqn'
      restart = .true.
      terminate = .false.
c
c     set default parameters for the optimization
c
      if (fctmin .eq. 0.0d0)  fctmin = -1000000.0d0
      if (maxiter .eq. 0)  maxiter = 1000000
      if (nextiter .eq. 0)  nextiter = 1
      if (iprint .lt. 0)  iprint = 1
      if (iwrite .lt. 0)  iwrite = 1
      if (scale .eq. 0.0d0)  scale = 1.0d0
      fast = 0.5d0
      slow = 0.0d0
      epsln = 1.0d-16
      period = max(200,nvar)
c
c     set default parameters for the line search
c
      if (cappa .eq. 0.0d0)  cappa = 0.1d0
      if (stpmin .eq. 0.0d0)  stpmin = 1.0d-16
      if (stpmax .eq. 0.0d0)  stpmax = 5.0d0
      if (angmax .eq. 0.0d0)  angmax = 88.0d0
      if (intmax .eq. 0)  intmax = 5
c
c     search the keywords for optimization parameters
c
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:17) .eq. 'STEEPEST-DESCENT ') then
            method = 'sd'
         else if (keyword(1:16) .eq. 'FLETCHER-REEVES ') then
            method = 'fr'
         else if (keyword(1:14) .eq. 'POLAK-RIBIERE ') then
            method = 'pr'
         else if (keyword(1:17) .eq. 'HESTENES-STIEFEL ') then
            method = 'hs'
         else if (keyword(1:13) .eq. 'POWELL-BEALE ') then
            method = 'pow'
         else if (keyword(1:7) .eq. 'FCTMIN ') then
            read (record(next:80),*,err=20)  fctmin
         else if (keyword(1:8) .eq. 'MAXITER ') then
            read (record(next:80),*,err=20)  maxiter
         else if (keyword(1:9) .eq. 'NEXTITER ') then
            read (record(next:80),*,err=20)  nextiter
         else if (keyword(1:9) .eq. 'PRINTOUT ') then
            read (record(next:80),*,err=20)  iprint
         else if (keyword(1:9) .eq. 'WRITEOUT ') then
            read (record(next:80),*,err=20)  iwrite
         else if (keyword(1:8) .eq. 'STEPMAX ') then
            read (record(next:80),*,err=20)  stpmax
         else if (keyword(1:8) .eq. 'STEPMIN ') then
            read (record(next:80),*,err=20)  stpmin
         else if (keyword(1:6) .eq. 'CAPPA ') then
            read (record(next:80),*,err=20)  cappa
         else if (keyword(1:7) .eq. 'ANGMAX ') then
            read (record(next:80),*,err=20)  angmax
         else if (keyword(1:6) .eq. 'EPSLN ') then
            read (record(next:80),*,err=20)  epsln
         else if (keyword(1:5) .eq. 'FAST ') then
            read (record(next:80),*,err=20)  fast
         else if (keyword(1:5) .eq. 'SLOW ') then
            read (record(next:80),*,err=20)  slow
         else if (keyword(1:7) .eq. 'PERIOD ') then
            read (record(next:80),*,err=20)  period
         else if (keyword(1:7) .eq. 'INTMAX ') then
            read (record(next:80),*,err=20)  intmax
         end if
   20    continue
      end do
c
c     get initial function and gradient values
c
      niter = nextiter - 1
      maxiter = niter + maxiter
      ncalls = ncalls + 1
      f = fgvalue (x,g)
      g_norm = 0.0d0
      do i = 1, nvar
         x_old(i) = x(i)
         g_old(i) = g(i)
         g_norm = g_norm + g(i)**2
      end do
      g_norm = sqrt(g_norm)
      f_move = 0.5d0 * stpmax * g_norm
      g_rms = g_norm * scale/rms
c
c     print header information prior to iterations
c
      if (iprint .gt. 0) then
         if (method .eq. 'sd') then
            write (iout,30)
   30       format (/,' Steepest Descent Gradient Optimization :')
         else if (method .eq. 'fr') then
            write (iout,40)
   40       format (/,' Fletcher-Reeves Conjugate Gradient',
     &                 ' Optimization :')
         else if (method .eq. 'pr') then
            write (iout,50)
   50       format (/,' Polak-Ribiere Conjugate Gradient',
     &                 ' Optimization :')
         else if (method .eq. 'hs') then
            write (iout,60)
   60       format (/,' Hestenes-Stiefel Conjugate Gradient',
     &                 ' Optimization :')
         else if (method .eq. 'pow') then
            write (iout,70)
   70       format (/,' Powell-Beale Conjugate Gradient Optimization :')
         else if (method .eq. 'mqn') then
            write (iout,80)
   80       format (/,' Memoryless BFGS Quasi-Newton Optimization :')
         end if
         write (iout,90)
   90    format (/,' CG Iter    F Value      G RMS     F Move',
     &             '    X Move    Angle  FG Call  Comment',/)
         if (f.lt.1.0d7 .and. f.gt.-1.0d6 .and. g_rms.lt.1.0d5) then
            write (iout,100)  niter,f,g_rms,ncalls
  100       format (i6,f13.4,f11.4,30x,i7)
         else
            write (iout,110)  niter,f,g_rms,ncalls
  110       format (i6,d13.4,d11.4,30x,i7)
         end if
      end if
c
c     tests of the various termination criteria
c
      if (niter .ge. maxiter) then
         status = 'IterLimit'
         terminate = .true.
      end if
      if (f .le. fctmin) then
         status = 'SmallFct '
         terminate = .true.
      end if
      if (g_rms .le. grdmin) then
         status = 'SmallGrad'
         terminate = .true.
      end if
c
c     start of a new conjugate gradient iteration
c
      dowhile (.not. terminate)
         niter = niter + 1
         if (status .eq. blank)  nerror = 0
c
c     if using GB/SA solvation, update Born radii occasionally
c
         if (use_gbsa) then
            if (mod(niter,50) .eq. 0) then
               reborn = 1
               call born
               f = fgvalue (x,g)
            end if
            reborn = 0
         end if
c
c     compute the next search direction using Steepest Descent,
c     Fletcher-Reeves CG, Polak-Ribiere CG or Memoryless BFGS
c
  120    continue
         status = blank
         if (method.eq.'sd' .or. restart) then
            do i = 1, nvar
               p(i) = -g(i)
            end do
            nstart = niter
            restart = .false.
         else if (method .eq. 'fr') then
            gg = 0.0d0
            gg_old = 0.0d0
            do i = 1, nvar
               gg = gg + g(i)*g(i)
               gg_old = gg_old + g_old(i)*g_old(i)
            end do
            beta = gg / gg_old
            do i = 1, nvar
               p(i) = -g(i) + beta*p(i)
            end do
         else if (method .eq. 'pr') then
            dg = 0.0d0
            gg_old = 0.0d0
            do i = 1, nvar
               dg = dg + d(i)*g(i)
               gg_old = gg_old + g_old(i)*g_old(i)
            end do
            beta = dg / gg_old
            do i = 1, nvar
               p(i) = -g(i) + beta*p(i)
            end do
         else if (method .eq. 'hs') then
            dg = 0.0d0
            dp = 0.0d0
            do i = 1, nvar
               dg = dg + d(i)*g(i)
               dp = dp + d(i)*p(i)
            end do
            beta = dg / dp
            do i = 1, nvar
               p(i) = -g(i) + beta*p(i)
            end do
         else if (method .eq. 'pow') then
            dg = 0.0d0
            dp = 0.0d0
            do i = 1, nvar
               dg = dg + d(i)*g(i)
               dp = dp + d(i)*p(i)
            end do
            beta = dg / dp
            if (niter .eq. ipow) then
               gamma = 0.0d0
            else
               dtg = 0.0d0
               dtpt = 0.0d0
               do i = 1, nvar
                  dtg = dtg + dt(i)*g(i)
                  dtpt = dtpt + dt(i)*pt(i)
               end do
               gamma = dtg / dtpt
            end if
            do i = 1, nvar
               p(i) = -g(i) + beta*p(i) + gamma*pt(i)
            end do
         else if (method .eq. 'mqn') then
            sg = 0.0d0
            dg = 0.0d0
            dd = 0.0d0
            sd = 0.0d0
            do i = 1, nvar
               sg = sg + s(i)*g(i)
               dg = dg + d(i)*g(i)
               dd = dd + d(i)*d(i)
               sd = sd + s(i)*d(i)
            end do
            do i = 1, nvar
               p(i) = -g(i) + (d(i)*sg+s(i)*dg)/sd
     &                   - (1.0d0+dd/sd)*(s(i)*sg/sd)
            end do
         end if
c
c     perform line search along the new conjugate direction
c
         f_old = f
         call search (nvar,f,g,x,p,f_move,angle,ncalls,fgvalue,status)
         f_new = f
c
c     if angle between the search direction and the negative
c     gradient vector was too large, use steepest descent
c
         if (status .eq. 'WideAngle') then
            restart = .true.
            goto 120
         end if
c
c     special test for reset of the Powell method
c
         if (method .eq. 'pow') then
            restart = .false.
            gg = 0.0d0
            gg_old = 0.0d0
            do i = 1, nvar
               gg = gg + g(i)*g(i)
               gg_old = gg_old + g(i)*g_old(i)
            end do
            ratio = gg_old / gg
            if (niter.eq.1 .or. ratio.ge.0.2d0) then
               ipow = niter + 1
               do i = 1, nvar
                  pt(i) = p(i)
                  dt(i) = g(i) - g_old(i)
               end do
               nstart = niter
               status = 'Resetting'
            end if
         end if
c
c     update variables based on results of this iteration
c
         f_move = f_old - f_new
         x_move = 0.0d0
         g_norm = 0.0d0
         do i = 1, nvar
            s(i) = x(i) - x_old(i)
            d(i) = g(i) - g_old(i)
            x_move = x_move + s(i)**2
            g_norm = g_norm + g(i)**2
            x_old(i) = x(i)
            g_old(i) = g(i)
         end do
         x_move = sqrt(x_move) / (scale * rms)
         if (coordtype .eq. 'internal') then
            x_move = radian * x_move
         end if
         g_norm = sqrt(g_norm)
         g_rms = g_norm * scale/rms
c
c     test for error/restart due to line search problems
c
         if (status .eq. 'BadIntpln') then
            nerror = nerror + 1
            if (nerror .eq. 3) then
               terminate = .true.
            else
               restart = .true.
            end if
         end if
         if (status .eq. 'IntplnErr') then
            nerror = nerror + 1
            if (nerror .eq. 3) then
               terminate = .true.
            else
               restart = .true.
            end if
            do i = 1, nvar
               x(i) = x_old(i)
               g(i) = g_old(i)
            end do
         end if
c
c     test for error/restart due to lack of movement
c
         if (x_move .lt. epsln) then
            status = 'SmallMove'
            nerror = nerror + 1
            if (nerror .eq. 3) then
               terminate = .true.
            else
               restart = .true.
            end if
         end if
c
c     test for error/restart due to function increase
c
         if (f_move .lt. 0.0d0) then
            status = 'Increase '
            nerror = nerror + 1
            if (nerror .eq. 3) then
               terminate = .true.
            else
               restart = .true.
            end if
            do i = 1, nvar
               x(i) = x_old(i)
               g(i) = g_old(i)
            end do
         end if
c
c     test for error/restart due to slow progress
c
         ratio = f_move / abs(f_new-fctmin)
         if (abs(ratio) .lt. slow) then
            status = 'SlowDecr '
            nerror = nerror + 1
            if (nerror .eq. 3) then
               terminate = .true.
            else
               restart = .true.
            end if
         end if
c
c     test for restart due to fast progress
c
         if (ratio .gt. fast) then
            status = 'FastDecr '
            nerror = 0
            restart = .true.
         end if
c
c     test for restart based on iterations since last restart
c
         if (niter-nstart .ge. period) then
            status = 'Periodic '
            restart = .true.
         end if
c
c     test for too many total iterations
c
         if (niter .ge. maxiter) then
            status = 'IterLimit'
            terminate = .true.
         end if
c
c     test the normal termination criteria
c
         if (f .le. fctmin) then
            status = 'SmallFct '
            terminate = .true.
         end if
         if (g_rms .le. grdmin) then
            status = 'SmallGrad'
            terminate = .true.
         end if
c
c     print intermediate results every few iterations
c
         if (iprint .gt. 0) then
            if (terminate .or. mod(niter,iprint).eq.0) then
               if (f.lt.1.0d7 .and. f.gt.-1.0d6 .and.
     &             g_rms.lt.1.0d5 .and. f_move.lt.1.0d5) then
                  write (iout,130)  niter,f,g_rms,f_move,
     &                              x_move,angle,ncalls,status
  130             format (i6,f13.4,f11.4,f11.4,f10.4,f9.2,i7,3x,a9)
               else
                  write (iout,140)  niter,f,g_rms,f_move,
     &                              x_move,angle,ncalls,status
  140             format (i6,d13.4,d11.4,d11.4,f10.4,f9.2,i7,3x,a9)
               end if
            end if
         end if
c
c     write intermediate results every few iterations
c
         if (iwrite .gt. 0) then
            if (terminate .or. mod(niter,iwrite).eq.0) then
               call writeout (x,niter)
            end if
         end if
      end do
c
c     set final value of the objective function
c
      minimum = f
      if (iprint .gt. 0) then
         if (status.eq.'SmallGrad' .or. status.eq.'SmallFct ') then
            write (iout,150)  status
  150       format (/,' LMQN  --  Normal Termination due to ',a9)
         else
            write (iout,160)  status
  160       format (/,' LMQN  --  Incomplete Convergence due to ',a9)
         end if
      end if
      return
      end
