c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine square  --  nonlinear least squares with bounds  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "square" is a nonlinear least squares routine derived from
c     the IMSL routine BCLSF and More's Minpack routine LMDER; the
c     Jacobian is estimated by finite differences and bounds can
c     be specified for the variables to be refined
c
c     arguments and variables :
c
c     n        number of variables to optimize
c     m        number of residual functions
c     xlo      vector of length n containing the lower bounds for
c                the variables
c     xhi      vector of length n containing the upper bounds for
c                the variables
c     xscale   vector of length n containing the diagonal scaling
c                matrix for the variables
c     xc       vector of length n containing the variable values
c                at the approximate solution
c     fc       vector of length m containing the residuals at the
c                approximate solution
c     fp       vector of length m containing the updated residual
c     xp       vector of length n containing the updated point
c     sc       vector of length n containing the last step taken
c     gc       vector of length n containing an estimate of
c                the gradient at the approximate solution
c     fjac     real m by n matrix containing an estimate of
c                the Jacobian at the approximate solution
c     mdim     leading dimension of fjac exactly as specified in
c                the dimension statement of the calling program
c     iactive  integer vector of length n indicating if xc(i) had
c                to be moved to an upper or lower bound
c     ipvt     vector of length n containing the permutation matrix
c                used in the QR factorization of the Jacobian at
c                the approximate solution
c     stpmax   real scalar containing the maximum allowed step size
c     delta    real scalar containing the trust region radius
c
c     required external routines :
c
c     rsdvalue   subroutine to evaluate residual function values
c     writeout   subroutine to write out info about current status
c
c
      subroutine square (m,n,xlo,xhi,xc,fc,gc,fjac,mdim,
     &                      grdmin,rsdvalue,writeout)
      implicit none
      include 'sizes.i'
      include 'iounit.i'
      include 'keys.i'
      include 'minima.i'
      integer maxlsq,maxrsd
      parameter (maxlsq=50)
      parameter (maxrsd=100)
      integer i,j,k,icode,next
      integer niter,ncalls,nactive
      integer m,n,mdim,nbigstp,ndigit
      integer iactive(maxlsq),ipvt(maxlsq)
      real*8 xc(maxlsq),xlo(maxlsq),xhi(maxlsq)
      real*8 fc(maxrsd),gc(maxlsq),fjac(mdim,maxlsq)
      real*8 xp(maxlsq),fp(maxrsd),ga(maxlsq),gs(maxlsq)
      real*8 sc(maxlsq),sa(maxlsq),ftemp(maxrsd)
      real*8 xscale(maxlsq),xsa(maxlsq)
      real*8 rdiag(maxlsq),qtf(maxlsq),work(maxlsq)
      real*8 amu,delta,epsfcn,fcnorm,fpnorm,gcnorm,ganorm
      real*8 precise,eps,grdmin,stpnorm,stpmax,stpmin
      real*8 rftol,faketol,xtemp,stepsz,sum,temp
      character*20 keyword
      character*80 record
      logical done,first,gauss,bigstp
      external rsdvalue,writeout,precise
c
c
c     check for too many variables or residuals
c
      if (n .gt. maxlsq) then
         write (iout,10)
   10    format (/,' SQUARE  --  Too many Parameters,',
     &              ' Increase value of MAXLSQ')
         return
      else if (m .gt. maxrsd) then
         write (iout,20)
   20    format (/,' SQUARE  --  Too many Residuals,',
     &              ' Increase value of MAXRSD')
         return
      end if
c
c     initialize various counters and status code
c
      niter = 0
      ncalls = 0
      nbigstp = 0
      done = .false.
c
c     setup the default tolerances and parameter values
c
      eps = precise (2)
      ndigit = 10
      if (eps .lt. 10.0d0**(-ndigit)) then
         eps = 10.0d0**(-ndigit)
      end if
      if (maxiter .eq. 0)  maxiter = 100
      if (iprint .lt. 0)  iprint = 1
      if (iwrite .lt. 0)  iwrite = 1
      if (fctmin .eq. 0.0d0)  fctmin = eps
      if (grdmin .eq. 0.0d0)  grdmin = eps**(1.0d0/3.0d0)
      epsfcn = sqrt(eps)
      delta = 0.0d0
      stpmax = 1000.0d0 * sqrt(float(n))
      stpmin = eps**(2.0d0/3.0d0)
      rftol = eps**(2.0d0/3.0d0)
      faketol = 100.0d0 * eps
c
c     search each line of the keyword file for options
c
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:7) .eq. 'FCTMIN ') then
            read (record(next:80),*,err=30)  fctmin
         else if (keyword(1:8) .eq. 'MAXITER ') then
            read (record(next:80),*,err=30)  maxiter
         else if (keyword(1:9) .eq. 'PRINTOUT ') then
            read (record(next:80),*,err=30)  iprint
         else if (keyword(1:9) .eq. 'WRITEOUT ') then
            read (record(next:80),*,err=30)  iwrite
         end if
   30    continue
      end do
c
c     check feasibility of variables and use bounds if needed
c
      nactive = 0
      do j = 1, n
         if (xc(j) .lt. xlo(j)) then
            xc(j) = xlo(j)
            iactive(j) = -1
         else if (xc(j) .gt. xhi(j)) then
            xc(j) = xhi(j)
            iactive(j) = 1
         else
            nactive = nactive + 1
            iactive(j) = 0
         end if
      end do
c
c     evaluate the function at the initial point
c
      ncalls = ncalls + 1
      call rsdvalue (m,n,xc,fc)
      fcnorm = 0.0d0
      do i = 1, m
         fcnorm = fcnorm + fc(i)**2
      end do
      fcnorm = 0.5d0 * fcnorm
c
c     evaluate the Jacobian at the initial point by finite
c     differences; replace loop with user routine if desired
c
      do j = 1, n
         stepsz = epsfcn * abs(xc(j))
         if (stepsz .lt. epsfcn)  stepsz = epsfcn
         if (xc(j) .lt. 0.0d0)  stepsz = -stepsz
         xtemp = xc(j)
         xc(j) = xtemp + stepsz
         ncalls = ncalls + 1
         call rsdvalue (m,n,xc,ftemp)
         xc(j) = xtemp
         do i = 1, m
            fjac(i,j) = (ftemp(i)-fc(i)) / stepsz
         end do
      end do
c
c     compute More's adaptive variable scale factors
c
      do j = 1, n
         temp = 0.0d0
         do i = 1, m
            temp = temp + fjac(i,j)**2
         end do
         xscale(j) = sqrt(temp)
         if (xscale(j) .eq. 0.0d0)  xscale(j) = 1.0d0
      end do
c
c     compute the total gradient vector for all variables
c
      do j = 1, n
         gc(j) = 0.0d0
         do i = 1, m
            gc(j) = gc(j) + fjac(i,j)*fc(i)
         end do
      end do
c
c     compute the norm of the scaled total gradient
c     and the scaled gradient for active variables
c
      gcnorm = 0.0d0
      ganorm = 0.0d0
      do j = 1, n
         gs(j) = gc(j) * max(abs(xc(j)),1.0d0/xscale(j))
         gcnorm = gcnorm + gs(j)**2
         if (iactive(j) .eq. 0) then
            ganorm = ganorm + gs(j)**2
         end if
      end do
      gcnorm = sqrt(gcnorm/n)
      if (nactive .ne. 0)  ganorm = sqrt(ganorm/nactive)
c
c     print out information about initial conditions
c
      if (iprint .gt. 0) then
         write (iout,40)
   40    format (/,' Levenberg-Marquardt Nonlinear Least Squares :')
         write (iout,50)
   50    format (/,' LS Iter    F Value      Total G     Active G',
     &             '    N Active   F Calls',/)
         if (max(fcnorm,gcnorm) .lt. 10000000.0d0) then
            write (iout,60)  niter,fcnorm,gcnorm,ganorm,nactive,ncalls
   60       format (i6,3f13.4,2i10)
         else
            write (iout,70)  niter,fcnorm,gcnorm,ganorm,nactive,ncalls
   70       format (i6,3d13.4,2i10)
         end if
      end if
c
c     write out the parameters, derivatives and residuals
c
      if (iwrite .eq. 1) then
         if (.not. done)  call writeout (niter,xc,gs,m,fc)
      end if
c
c     check stopping criteria at the initial point; test the
c     absolute function value and gradient norm for termination
c
      if (fcnorm .le. fctmin)  return
      if (ganorm .le. grdmin)  return
c
c     start of the main body of least squares iteration
c
   80 continue
      niter = niter + 1
c
c     repack the Jacobian to include only active variables
c
      if (nactive .ne. n) then
         k = 0
         do j = 1, n
            if (iactive(j) .ne. 0) then
               if (k .eq. 0)  k = j
            else
               if (k .ne. 0) then
                  do i = 1, m
                     fjac(i,k) = fjac(i,j)
                  end do
                  k = k + 1
               end if
            end if
         end do
      end if
c
c     repack scale factors and gradient for active variables
c
      k = 0
      do j = 1, n
         if (iactive(j) .eq. 0) then
            k = k + 1
            xsa(k) = xscale(j)
            ga(k) = gc(j)
         end if
      end do
c
c     compute the QR factorization of the Jacobian
c
      call qrfact (m,nactive,fjac,mdim,.true.,ipvt,rdiag,work)
c
c     compute the vector Q(transpose) * residuals
c
      do i = 1, m
         qtf(i) = fc(i)
      end do
      do j = 1, nactive
         if (fjac(j,j) .ne. 0.0d0) then
            sum = 0.0d0
            do i = j, m
               sum = sum + fjac(i,j)*qtf(i)
            end do
            temp = -sum / fjac(j,j)
            do i = j, m
               qtf(i) = qtf(i) + fjac(i,j)*temp
            end do
         end if
         fjac(j,j) = rdiag(j)
      end do
c
c     compute the Levenberg-Marquardt step
c
      icode = 6
      first = .true.
      dowhile (icode .ge. 4)
         call lmstep (nactive,ga,fjac,mdim,ipvt,xsa,qtf,stpmax,
     &                       delta,amu,first,sa,gauss)
c
c     unpack the step vector to include all variables
c
         k = 0
         do i = 1, n
            if (iactive(i) .ne. 0) then
               sc(i) = 0.0d0
            else
               k = k + 1
               sc(i) = sa(k)
            end if
         end do
c
c     check new point and update the trust region
c
         call trust (rsdvalue,m,n,xc,fcnorm,gc,fjac,mdim,ipvt,sc,sa,
     &               xscale,gauss,stpmax,delta,icode,xp,fc,fp,fpnorm,
     &               bigstp,ncalls,xlo,xhi,nactive,stpmin,rftol,faketol)
      end do
      if (icode .eq. 1)  done = .true.
c
c     update to the new variables and residuals
c
      do j = 1, n
         xc(j) = xp(j)
      end do
      do i = 1, m
         fc(i) = fp(i)
      end do
      fcnorm = fpnorm
c
c     update the active vs inactive status of the variables;
c     in a true active set strategy, at most one constraint
c     is added to the active set per iteration
c
      do j = 1, n
         if (iactive(j) .eq. 0) then
            if (abs(xc(j)-xlo(j)) .le. eps) then
               nactive = nactive - 1
               iactive(j) = -1
c              goto 110
            else if (abs(xc(j)-xhi(j)) .le. eps) then
               nactive = nactive - 1
               iactive(j) = 1
c              goto 110
            end if
         end if
      end do
   90 continue
c
c     evaluate the Jacobian at the new point using finite
c     differences; replace loop with user routine if desired
c
      do j = 1, n
         stepsz = epsfcn * max(abs(xc(j)),1.0d0/xscale(j))
         if (xc(j) .lt. 0.0d0)  stepsz = -stepsz
         xtemp = xc(j)
         xc(j) = xtemp + stepsz
         ncalls = ncalls + 1
         call rsdvalue (m,n,xc,ftemp)
         xc(j) = xtemp
         do i = 1, m
            fjac(i,j) = (ftemp(i)-fc(i)) / stepsz
         end do
      end do
c
c     compute More's adaptive variable scale factors
c
      do j = 1, n
         temp = 0.0d0
         do i = 1, m
            temp = temp + fjac(i,j)**2
         end do
         xscale(j) = max(xscale(j),sqrt(temp))
      end do
c
c     compute the total gradient vector for all variables
c
      do j = 1, n
         gc(j) = 0.0d0
         do i = 1, m
            gc(j) = gc(j) + fjac(i,j)*fc(i)
         end do
      end do
c
c     compute the norm of the scaled total gradient
c     and the scaled gradient for active variables
c
      gcnorm = 0.0d0
      ganorm = 0.0d0
      do j = 1, n
         gs(j) = gc(j) * max(abs(xc(j)),1.0d0/xscale(j))
         gcnorm = gcnorm + gs(j)**2
         if (iactive(j) .eq. 0) then
            ganorm = ganorm + gs(j)**2
         end if
      end do
      gcnorm = sqrt(gcnorm/n)
      if (nactive .ne. 0)  ganorm = sqrt(ganorm/nactive)
c
c     print out information about current iteration
c
      if (iprint.ne.0 .and. mod(niter,iprint).eq.0) then
         if (max(fcnorm,gcnorm) .lt. 10000000.0d0) then
            write (iout,100)  niter,fcnorm,gcnorm,ganorm,nactive,ncalls
  100       format (i6,3f13.4,2i10)
         else
            write (iout,110)  niter,fcnorm,gcnorm,ganorm,nactive,ncalls
  110       format (i6,3d13.4,2i10)
         end if
      end if
c
c     check stopping criteria at the new point; test the absolute
c     function value, the gradient norm and step for termination
c
      if (fcnorm .le. fctmin)  done = .true.
      if (ganorm .le. grdmin)  done = .true.
      stpnorm = 0.0d0
      do j = 1, n
         temp = max(abs(xc(j)),1.0d0/xscale(j))
         stpnorm = stpnorm + (sc(j)/temp)**2
      end do
      stpnorm = sqrt(stpnorm/n)
      if (stpnorm .le. stpmin)  done = .true.
c
c     check for inactive variables that can be made active;
c     in a true active set strategy, variables are released
c     one at a time at a minimum of the current active set
c
c     if (done) then
      if (nactive .ne. n) then
         do j = 1, n
            if (iactive(j).eq.-1 .and. gc(j).lt.0.0d0) then
               nactive = nactive + 1
               iactive(j) = 0
               done = .false.
c                 goto 140
            else if (iactive(j).eq.1 .and. gc(j).gt.0.0d0) then
               nactive = nactive + 1
               iactive(j) = 0
               done = .false.
c                 goto 140
            end if
         end do
  120    continue
      end if
c     end if
c
c     if still done, then normal termination has been achieved
c
      if (done) then
         write (iout,130)
  130    format (/,' SQUARE  --  Normal Termination of Least Squares')
      end if
c
c     check the limit on the number of iterations
c
      if (niter .ge. maxiter) then
         done = .true.
         write (iout,140)
  140    format (/,' SQUARE  --  Maximum Number of Allowed Iterations')
      end if
c
c     check relative function convergence and false convergence
c
      if (icode .eq. 2) then
         done = .true.
         write (iout,150)
  150    format (/,' SQUARE  --  Relative Function Convergence',
     &           //,' Both the scaled actual and predicted',
     &               ' reductions in the function',
     &           /,' are less than or equal to the relative',
     &               ' convergence tolerance')
      else if (icode .eq. 3) then
         done = .true.
         write (iout,160)
  160    format (/,' SQUARE  --  Possible False Convergence',
     &           //,' The iterates appear to be converging to',
     &               ' a noncritical point due',
     &           /,' to bad gradient information, discontinuous',
     &               ' function, or stopping',
     &           /,' tolerances being too tight')
      end if
c
c     check for several consecutive maximum steps taken
c
      if (bigstp) then
         nbigstp = nbigstp + 1
         if (nbigstp .eq. 5) then
            done = .true.
            write (iout,170)
  170       format (/,' SQUARE  --  Five Consecutive Maximum',
     &                  ' Length Steps',
     &              //,' Either the function is unbounded below,',
     &                  ' or has a finite',
     &              /,' asymptote in some direction, or STEPMAX',
     &                  ' is too small')
         end if
      else
         nbigstp = 0
      end if
c
c     write out the parameters, derivatives and residuals
c
      if (iwrite.ne.0 .and. mod(niter,iwrite).eq.0) then
         if (.not. done)  call writeout (niter,xc,gs,m,fc)
      end if
c
c     continue with the next iteration if not finished
c
      if (.not. done)  goto 80
      return
      end
