      program multistartM2

      implicit none

#include "packdata.com"
#include "partdata.com"

C     PARAMETERS
      integer mmax,nmax
      double precision pi
      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( pi        = 3.1415926535898d0 )

C     COMMON SCALARS
      integer insnum,setnum
      double precision a,b,r

C     LOCAL SCALARS
      logical checkder,usinglb
      integer i,idummy,inform,iniopt,iprint,itrial,m,n,ncomp,nitelb,
     +        solitrial,solnite,soltotitrial,totitrial,flag,cindmaxk
      double precision ang,cnorm,ddummy,epsfeas,epsopt,f,feas,nlpsupn,
     +        seed,snorm,solf,solfeas,soltime,cindmaxv
      real time,timeini,timemax

C     LOCAL ARRAYS
      logical coded(10),equatn(mmax),linear(mmax)
      double precision l(nmax),lambda(mmax),ss(nitemax),u(nmax),
     +        uu(nitemax),vv(nitemax),x(nmax)
      real tarray(2)

C     COMMON BLOCKS
      common /idprobdat/ insnum,setnum
      common /probindat/ a,b,r

C     EXTERNAL FUNCTIONS
      double precision drand,cmax
      external drand,cmax

C     READ PROBLEM DATA

      write(*,*) 'Enter set number and instance number: '
      read(*,*) setnum,insnum

      if ( setnum .eq. 0 ) then
          insnum = 0
          write(*,*) 'Enter a and b (a >= b): '
          read(*,*) a,b

      else if ( setnum .eq. 1 ) then
          b = insnum + 1.0d0
          a = 2.0d0 * b

      else if ( setnum .eq. 2 ) then
          b = 15.0d0 - insnum
          a = 450.0d0 / b

      else if ( setnum .eq. 3 ) then
          if ( insnum .eq. 1 ) then
              a = 150.0d0 * 2.0d0 / 3.0d0
              b =   3.0d0 * 2.0d0 / 3.0d0
          else if ( insnum .eq. 2 ) then
              a = 150.0d0 / 2.0d0
              b =   3.0d0 / 2.0d0
          else if ( insnum .eq. 3 ) then
              a = 112.5d0 * 2.0d0 / 3.0d0
              b =   4.0d0 * 2.0d0 / 3.0d0
          else if ( insnum .eq. 4 ) then
              a = 112.5d0 / 2.0d0
              b =   4.0d0 / 2.0d0
          else if ( insnum .eq. 5 ) then
              a =  90.0d0 * 2.0d0 / 3.0d0
              b =   5.0d0 * 2.0d0 / 3.0d0        
          else if ( insnum .eq. 6 ) then
              a =  90.0d0 / 2.0d0          
              b =   5.0d0 / 2.0d0
          end if          
      end if

      write(*,*) 'Enter r: '
      read(*,*) r

c     r = 1.0d0

      write(*,*) 'Lower bound with lattice ( [T]tue / [F]alse )?'
      read(*,*) usinglb

      write(*,*) 'Maximum time (in secs): '
      read(*,*) timemax

      write(*,*) 'Running: ',a,b,r,usinglb,timemax

      if ( usinglb ) then

          open(unit=80,file='lattice.txt')
          read(80,*) nitelb

          do i = 1,nitelb
              read(80,*) idummy,uu(i),vv(i),ss(i)
          end do
          close(80)

      else
          nitelb = 0
      end if

      solnite      = nitelb
      soltotitrial = 0
      solitrial    = 0
      soltime      = 0.0d0
      solfeas      = 0.0d0
      solf         = 0.0d0

C     MAIN LOOP (INCREASING nite)

      call etime(tarray,timeini)
      timeini = tarray(1)
      time = timeini

      totitrial = 0

      nite = nitelb + 1

 180  continue

C     SECONDARY LOOP (MULTISTART FOR FIXED m)

      itrial = 0

 190  continue

C     STOP IF THE TIME LIMIT IS EXCEEDED

      if ( time .ge. timemax ) then
          go to 210
      end if

      itrial    = itrial    + 1
      totitrial = totitrial + 1 

C     SET INITIAL GUESS

      seed = itrial
      ddummy = drand( seed )

      if ( itrial .eq. 1 ) then
          if ( nite .eq. nitelb + 1 ) then
              do i = 1,nitelb
                  x(3*i-2) = uu(i)
                  x(3*i-1) = vv(i)
                  x(3*i  ) = ss(i)
              end do
          end if

          ang = 2.0d0 * pi * drand( seed )
          x(3*nite-2) = a * cos( ang )
          x(3*nite-1) = b * sin( ang )
          x(3*nite  ) =  drand(seed) * 0.5d0

      else
          call cindmax(n,x,cindmaxv,cindmaxk)

          ang = 2.0d0 * pi * drand( seed )
          x(3*cindmaxk-2) = a * cos( ang )
          x(3*cindmaxk-1) = b * sin( ang )
          x(3*cindmaxk  ) =  drand(seed) * 0.5d0
      end if

C     CALL THE NLP SOLVER

      call inip(n,x,l,u,m,lambda,equatn,linear,coded,checkder)

      epsfeas = 1.0d-08
      epsopt  = 1.0d-08

      iprint  = 11
      ncomp   = 6

      call algencan(epsfeas,epsopt,iprint,ncomp,n,x,l,u,m,lambda,equatn,
     +linear,coded,checkder,f,cnorm,snorm,nlpsupn,inform)

      call etime(tarray,time)
      time = tarray(1) - timeini

C     CHECK WHETHER A SOLUTION WAS FOUND OR NOT AND ITERATE

      feas = cmax(n,x)

      if ( feas .le. 1.0d-04 ) then

          write(*,*) 'Solution with ',nite,' items found using seed ',
     +               itrial,' (time = ',time,
     +               ' total number of seeds = ',totitrial,')'

          solnite      = nite
          soltotitrial = totitrial
          solitrial    = itrial
          soltime      = time
          solfeas      = feas
          solf         = f

          call drawsol(n,x)

          open(80,file='tabline.txt')
          write(80,100) a,b,r,usinglb,timemax,nitelb,solnite,
     +                  soltotitrial,solitrial,soltime,solfeas,solf,
     +                  totitrial - soltotitrial
          close(80)

          do i = 1,nite
              uu(i) = x( 3 * i - 2 )
              vv(i) = x( 3 * i - 1 )
              ss(i) = x( 3 * i     )
          end do    

          call savesol(nite,uu,vv,ss)

          nite = nite + 1
          go to 180      

      else
          open(80,file='tabline.txt')
          write(80,100) a,b,r,usinglb,timemax,nitelb,solnite,
     +                  soltotitrial,solitrial,soltime,solfeas,solf,
     +                  totitrial - soltotitrial
          close(80)

          go to 190
      end if

C     STOP

 210  continue

      stop

C     NON-EXECUTABLE STATEMENTS

 100  format(F8.2,1X,F8.2,1X,F8.2,1X,1L,1X,F8.2,1X,I4,1X,I4,1X,I7,
     +       1X,I7,1X,0P,F8.2,1X,1P,D7.1,1X,1P,D7.1,1X,I10)

      end

C     ******************************************************************
C     ******************************************************************

      subroutine savesol(m,u,v,s)

C     SCALAR ARGUMENTS
      integer m

C     ARRAY ARGUMENTS
      double precision u(m),v(m),s(m)

#include "packdata.com"
C     COMMON SCALARS
      integer insnum,setnum

C     LOCAL SCALARS
      integer i

C     LOCAL ARRAYS
      character * 20 filename
      character * 3 ms

C     COMMON BLOCKS
      common /idprobdat/ insnum,setnum

      open(unit=91,file='multistart.out')

      write(91,99) setnum,insnum
      write(91,100) m

      do i = 1,m
          write(91,200) i,u(i),v(i),s(i)
      end do

      close(91)

C     NON-EXECUTABLE STATEMENTS
  99  format(I4,1X,I4)
 100  format(I7)
 200  format(I7,3(1X,1P,D24.16))

      end

C     ******************************************************
C     ******************************************************

      subroutine drawsol(n,x)

      implicit none 

C     SCALAR ARGUMENTS
      integer n

C     ARRAY ARGUMENTS
      double precision x(n)

#include "packdata.com"

C     LOCAL SCALARS
      integer i
      double precision a,b,qx,qy,r,s,scale,xx,yy

      a = sqrt( a2 )
      b = sqrt( b2 )
      r = sqrt( r2 )

      open(unit=10,file='multistart.mp')

C     SCALING
      scale = 10.0d0 / max( 2.0d0 * a, 2.0d0 * b )
      write(10,10) scale
      write(10,11)

C     ELLIPSE
      write(10,20) 2.0d0*a,2.0d0*b,0.0d0,0.0d0

C     CIRCULAR ITEMS
      do i = 1,nite
          qx = x( 3 * i - 2 )
          qy = x( 3 * i - 1 )
          s  = x( 3 * i     )

          xx = ( 1.0d0 + ( s - 1.0d0 ) * ( b2 / a2 ) ) * qx
          yy = s * qy

          write(10,20) 2.0d0*r,2.0d0*r,xx,yy
      end do

      write(10,30)

      close(10)

C     NON-EXECUTABLE STATEMENTS

  10  format('beginfig(-1);'/,'u = ',f20.10,'cm;')
  11  format('pickup pencircle scaled 0.01;')
  20  format('draw fullcircle',
     +       /,'     xscaled  ',f20.10,'u',
     +       /,'     yscaled  ',f20.10,'u',
     +       /,'     shifted (',f20.10,'u,',f20.10,'u);')
  30  format('endfig;',/,'end;') 

      end

C     ******************************************************************
C     ******************************************************************

      subroutine inip(n,x,l,u,m,lambda,equatn,linear,coded,checkder)

      implicit none

C     SCALAR ARGUMENTS
      integer m,n
      logical checkder

C     ARRAY ARGUMENTS
      logical coded(10),equatn(*),linear(*)
      double precision l(*),lambda(*),u(*),x(*)

#include "packdata.com"
#include "partdata.com"

C     COMMON SCALARS
      double precision a,b,r

C     LOCAL SCALARS
      integer ceil,i,j

C     COMMON BLOCKS
      common /probindat/ a,b,r

C     SET PROBLEM DATA

C     Squared constants

      a2 = a ** 2
      b2 = b ** 2
      r2 = r ** 2

C     Initialize regions

      nrega = ceil( a / r )
      nregb = ceil( b / r )

      do i = 0,nrega + 1
          do j = 0,nregb + 1
              start(i,j) = 0
          end do 
      end do

C     Number of variables

      n = 3 * nite

C     Initial point (in the main program!)

C     Lower and upper bounds

      do i = 1,nite
          l(3*i-2) = - 1.0d+20
          l(3*i-1) = - 1.0d+20
          l(3*i  ) =   0.0d0

          u(3*i-2) =   1.0d+20
          u(3*i-1) =   1.0d+20
          u(3*i  ) =   1.0d0
      end do

C     Number of constraints (equalities plus inequalities)

      m = 0

C     Indicate which subroutines did you code.

      coded( 1) = .true.  ! evalf
      coded( 2) = .true.  ! evalg
      coded( 3) = .true.  ! evalh
      coded( 4) = .false. ! evalc
      coded( 5) = .false. ! evaljac
      coded( 6) = .false. ! evalhc
      coded( 7) = .false. ! evalfc
      coded( 8) = .false. ! evalgjac
      coded( 9) = .false. ! evalhl
      coded(10) = .false. ! evalhlp

C     Set checkder = .true. if you code some derivatives and you would
C     like them to be tested by finite differences. It is highly
C     recommended.

      checkder = .false.

      end

C     ******************************************************************
C     ******************************************************************

      subroutine evalf(n,x,f,flag)

      implicit none

C     SCALAR ARGUMENTS
      integer flag,n
      double precision f

C     ARRAY ARGUMENTS
      double precision x(n)

C     EXTERNAL FUNCTIONS
      double precision belong,overlap

      flag = 0

      f = 0.0d0
      f = f + belong(n,x,flag) 
      f = f + overlap(n,x,flag)

      end

C     ******************************************************************
C     ******************************************************************

      subroutine evalg(n,x,g,flag)

      implicit none

C     SCALAR ARGUMENTS
      integer flag,n

C     ARRAY ARGUMENTS
      double precision g(n),x(n)

C     LOCAL SCALARS
      integer i

      flag = 0

      do i = 1,n
          g(i) = 0.0d0
      end do

      call gbelong(n,x,g,flag)
      call goverlap(n,x,g,flag)

      end

C     ******************************************************************
C     ******************************************************************

      subroutine evalh(n,x,hlin,hcol,hval,hnnz,flag)

      implicit none

C     SCALAR ARGUMENTS
      integer flag,hnnz,n

C     ARRAY ARGUMENTS
      integer hcol(*),hlin(*)
      double precision hval(*),x(n)

      flag = 0

      hnnz = 0

      call hbelong(n,x,hlin,hcol,hval,hnnz,flag)
      call hoverlap(n,x,hlin,hcol,hval,hnnz,flag)

      end

C     ******************************************************************
C     ******************************************************************
 
      double precision function belong(n,x,flag)

      implicit none

C     SCALAR ARGUMENTS
      integer flag,n

C     ARRAY ARGUMENTS
      double precision x(n)

#include "packdata.com"

C     LOCAL SCALARS
      integer i
      double precision c,qx,qy,s

      flag = 0

      belong = 0.0d0

      do i = 1,nite
          qx = x( 3 * i - 2 )
          qy = x( 3 * i - 1 )
          s  = x( 3 * i     )

C         Belonging (part 1)

          c = 1.0d0 - ( s - 1.0d0 ) ** 2 * 
     +                ( ( b2 / a2 ) ** 2 * qx ** 2 + qy ** 2 ) / r2

          belong = belong + 0.5d0 * max( 0.0d0, c ) ** 2

C         Belonging (part 2)

          c = qx ** 2 / a2 + qy ** 2 / b2 - 1.0d0

          belong = belong + 0.5d0 * c ** 2
      end do

      end

C     ******************************************************************
C     ******************************************************************
 
      subroutine gbelong(n,x,g,flag)

      implicit none

C     SCALAR ARGUMENTS
      integer flag,n

C     ARRAY ARGUMENTS
      double precision g(n),x(n)

#include "packdata.com"

C     LOCAL SCALARS
      integer i
      double precision c,dcdqx,dcdqy,dcds,qx,qy,s,tmp

      flag = 0

      do i = 1,nite
          qx = x( 3 * i - 2 )
          qy = x( 3 * i - 1 )
          s  = x( 3 * i     )

C         Belonging (part 1)

          c = 1.0d0 - ( s - 1.0d0 ) ** 2 * 
     +                ( ( b2 / a2 ) ** 2 * qx ** 2 + qy ** 2 ) / r2

          if ( c .gt. 0.0d0 ) then

              tmp   = - 2.0d0 * ( s - 1.0d0 ) ** 2 / r2

              dcdqx = ( b2 / a2 ) ** 2 * tmp * qx
              dcdqy = tmp * qy
              dcds  = - ( 2.0d0 * ( s - 1.0d0 ) / r2 ) * 
     +                ( ( b2 / a2 ) ** 2 * qx ** 2 + qy ** 2 )

              g(3 * i - 2) = g(3 * i - 2) + c * dcdqx
              g(3 * i - 1) = g(3 * i - 1) + c * dcdqy
              g(3 * i    ) = g(3 * i    ) + c * dcds

          end if

C         Belonging (part 2)

          c = qx ** 2 / a2 + qy ** 2 / b2 - 1.0d0

          g(3 * i - 2) = g(3 * i - 2) + c * 2.0d0 * qx / a2
          g(3 * i - 1) = g(3 * i - 1) + c * 2.0d0 * qy / b2
      end do

      end

C     ******************************************************************
C     ******************************************************************
 
      subroutine hbelong(n,x,hlin,hcol,hval,hnnz,flag)

      implicit none

C     SCALAR ARGUMENTS
      integer flag,hnnz,n

C     ARRAY ARGUMENTS
      integer hcol(*),hlin(*)
      double precision hval(*),x(n)

#include "packdata.com"

C     LOCAL SCALARS
      integer i
      double precision c,dcdqx,dcdqy,dcds,dcdqxqx,dcdqyqy,dcdsqx,dcdsqy,
     +        dcdss,qx,qy,s,tmp,tmp2,dtmp2ds

      flag = 0

      do i = 1,nite
          qx = x( 3 * i - 2 )
          qy = x( 3 * i - 1 )
          s  = x( 3 * i     )

C         Belonging (part 1)

          c = 1.0d0 - ( s - 1.0d0 ) ** 2 * 
     +                ( ( b2 / a2 ) ** 2 * qx ** 2 + qy ** 2 ) / r2

          if ( c .gt. 0.0d0 ) then

              tmp = - 2.0d0 * ( s - 1.0d0 ) ** 2 / r2

              dcdqx = ( b2 / a2 ) ** 2 * tmp * qx

              dcdqxqx =  ( b2 / a2 ) ** 2 * tmp 

              dcdqy = tmp * qy

              dcdqyqy = tmp
             
              tmp2 = - 2.0d0 * ( s - 1.0d0 ) / r2

              dtmp2ds  = - 2.0d0 / r2

              dcds  = tmp2 * ( ( b2 / a2 ) ** 2 * qx ** 2 + qy ** 2 )

              dcdsqx = 2.0d0 * tmp2 * ( b2 / a2 ) ** 2 * qx
              dcdsqy = 2.0d0 * tmp2 * qy
              dcdss  = ( ( b2 / a2 ) ** 2 * qx ** 2 + qy ** 2 ) *dtmp2ds

c             g(3 * i - 2) = g(3 * i - 2) + c * dcdqx

              hlin(hnnz + 1) = 3 * i - 2
              hcol(hnnz + 1) = 3 * i - 2
              hval(hnnz + 1) = dcdqx ** 2 + c * dcdqxqx

c             g(3 * i - 1) = g(3 * i - 1) + c * dcdqy

              hlin(hnnz + 2) = 3 * i - 1
              hcol(hnnz + 2) = 3 * i - 2
              hval(hnnz + 2) = dcdqy * dcdqx

              hlin(hnnz + 3) = 3 * i - 1
              hcol(hnnz + 3) = 3 * i - 1
              hval(hnnz + 3) = dcdqy ** 2 + c * dcdqyqy

c             g(3 * i    ) = g(3 * i    ) - c * dcds

              hlin(hnnz + 4) = 3 * i
              hcol(hnnz + 4) = 3 * i - 2
              hval(hnnz + 4) =  dcdqx * dcds + c * dcdsqx

              hlin(hnnz + 5) = 3 * i
              hcol(hnnz + 5) = 3 * i - 1
              hval(hnnz + 5) =  dcdqy * dcds + c * dcdsqy

              hlin(hnnz + 6) = 3 * i
              hcol(hnnz + 6) = 3 * i
              hval(hnnz + 6) =  dcds ** 2 + c * dcdss

              hnnz = hnnz + 6

          end if

C         Belonging (part 2)

          c = qx ** 2 / a2 + qy ** 2 / b2 - 1.0d0

          dcdqx = 2.0d0 * qx / a2
          dcdqy = 2.0d0 * qy / b2

          hlin(hnnz + 1) = 3 * i - 2
          hcol(hnnz + 1) = 3 * i - 2
          hval(hnnz + 1) = dcdqx ** 2 + c * 2.0d0 / a2

          hlin(hnnz + 2) = 3 * i - 1
          hcol(hnnz + 2) = 3 * i - 1
          hval(hnnz + 2) = dcdqy ** 2 + c * 2.0d0 / b2

          hlin(hnnz + 3) = 3 * i - 1
          hcol(hnnz + 3) = 3 * i - 2
          hval(hnnz + 3) = dcdqx * dcdqy

          hnnz = hnnz + 3

      end do

      end

C     ******************************************************************
C     ******************************************************************

      double precision function overlap(n,x,flag)

      implicit none

C     SCALAR ARGUMENTS
      integer flag,n

C     ARRAY ARGUMENTS
      double precision x(n)

#include "partdata.com"

C     LOCAL SCALARS
      integer i,j,k,l
      double precision nrdist

      flag = 0

C     CLASSIFY ITEMS BY REGIONS

      call classify(n,x)
 
C     COMPUTE SPARSE OVERLAPPING

      overlap = 0.0d0

      do k = 1,nbr
          i = br(1,k)
          j = br(2,k)
          l = start(i,j)
 10       if ( l .ne. 0 ) then
              overlap = 
     +        overlap + nrdist(n,x,l,next(l))        + 
     +                  nrdist(n,x,l,start(i-1,j+1)) + 
     +                  nrdist(n,x,l,start(i,  j+1)) + 
     +                  nrdist(n,x,l,start(i+1,j+1)) + 
     +                  nrdist(n,x,l,start(i+1,j))
              l = next(l)
              go to 10
          end if
      end do

      end

C     ******************************************************************
C     ******************************************************************
 
      subroutine goverlap(n,x,g,flag)

      implicit none

C     SCALAR ARGUMENTS
      integer flag,n

C     ARRAY ARGUMENTS
      double precision g(n),x(n)

#include "partdata.com"

C     LOCAL SCALARS
      integer i,j,k,l

      flag = 0

C     CLASSIFY ITEMS BY REGIONS

      call classify(n,x)
 
C     COMPUTE SPARSE OVERLAPPING

      do k = 1,nbr
          i = br(1,k)
          j = br(2,k)
          l = start(i,j)
 10       if ( l .ne. 0 ) then
              call gnrdist(n,x,g,l,next(l)) 
              call gnrdist(n,x,g,l,start(i-1,j+1))
              call gnrdist(n,x,g,l,start(i,  j+1))  
              call gnrdist(n,x,g,l,start(i+1,j+1))  
              call gnrdist(n,x,g,l,start(i+1,j  ))
              l = next(l)
              go to 10
          end if
      end do

      end

C     ******************************************************************
C     ******************************************************************
 
      subroutine hoverlap(n,x,hlin,hcol,hval,hnnz,flag)

      implicit none

C     SCALAR ARGUMENTS
      integer flag,n,hnnz

C     ARRAY ARGUMENTS
      integer hcol(*),hlin(*)
      double precision hval(*),x(n)

#include "packdata.com"
#include "partdata.com"

C     COMMON ARRAYS
      double precision diagb(3*nitemax)

C     LOCAL SCALARS
      integer i,j,k,l

C     COMMON BLOCKS
      common /diblocks/ diagb

      flag = 0

C     CLASSIFY ITEMS BY REGIONS

      call classify(n,x)

C     INITALIZE DIAGONAL ELEMENTS

      do k = 1,3 * nite
          diagb(k) = 0.0d0
      end do

C     COMPUTE SPARSE OVERLAPPING SECOND DERIVATIVES

      do k = 1,nbr
          i = br(1,k)
          j = br(2,k)
          l = start(i,j)
 10       if ( l .ne. 0 ) then
              call hnrdist(n,x,hlin,hcol,hval,hnnz,l,next(l)) 
              call hnrdist(n,x,hlin,hcol,hval,hnnz,l,start(i-1,j+1))
              call hnrdist(n,x,hlin,hcol,hval,hnnz,l,start(i,  j+1))  
              call hnrdist(n,x,hlin,hcol,hval,hnnz,l,start(i+1,j+1))  
              call hnrdist(n,x,hlin,hcol,hval,hnnz,l,start(i+1,j  ))
              l = next(l)
              go to 10
          end if
      end do

C     ADD DIAGONAL ELEMENTS TO THE SPARSE STRUCTURE
      do k = 1,3 * nite
          if ( diagb(k) .ne. 0.0d0 ) then
              hnnz = hnnz + 1
              hlin(hnnz) = k
              hcol(hnnz) = k
              hval(hnnz) = diagb(k)
          end if
      end do
      
      end

C     ******************************************************************
C     ******************************************************************
 
      double precision function nrdist(n,x,i,lstart)

      implicit none

C     SCALAR ARGUMENTS
      integer i,lstart,n

C     ARRAY ARGUMENTS
      double precision x(n)

#include "packdata.com"
#include "partdata.com"

C     LOCAL SCALARS
      integer j
      double precision c,qxi,qxj,qyi,qyj,si,sj,taui,tauj

      nrdist = 0.0d0

      qxi = x( 3 * i - 2 )
      qyi = x( 3 * i - 1 )
      si  = x( 3 * i     )

      taui = 1.0d0 + ( si - 1.0d0 ) * ( b2 / a2 )

      j = lstart

 10   if ( j .ne. 0 ) then

          qxj = x( 3 * j - 2 )
          qyj = x( 3 * j - 1 )
          sj  = x( 3 * j     )

          tauj = 1.0d0 + ( sj - 1.0d0 ) * ( b2 / a2 )

          c = 1.0d0 - ( taui * qxi - tauj * qxj ) ** 2 / ( 4.0d0 * r2 )
     +              - ( si   * qyi - sj   * qyj ) ** 2 / ( 4.0d0 * r2 )

          nrdist = nrdist + 0.5d0 * max( 0.0d0, c ) ** 2

          j = next(j)
          go to 10

      end if

      end

C     ******************************************************************
C     ******************************************************************
 
      subroutine gnrdist(n,x,g,i,lstart)

      implicit none

C     SCALAR ARGUMENTS
      integer i,lstart,n

C     ARRAY ARGUMENTS
      double precision g(n),x(n)

#include "packdata.com"
#include "partdata.com"

C     LOCAL SCALARS
      integer j
      double precision c,qxi,qxj,qyi,qyj,si,sj,taui,tauj,tmpa,tmpb,
     +        dcdqxi,dcdqxj,dcdqyi,dcdqyj,dcdsi,dcdsj

      qxi = x( 3 * i - 2 )
      qyi = x( 3 * i - 1 )
      si  = x( 3 * i     )

      taui = 1.0d0 + ( si - 1.0d0 ) * ( b2 / a2 )

      j = lstart

 10   if ( j .ne. 0 ) then

          qxj = x( 3 * j - 2 )
          qyj = x( 3 * j - 1 )
          sj  = x( 3 * j     )

          tauj = 1.0d0 + ( sj - 1.0d0 ) * ( b2 / a2 )

          c = 1.0d0 - ( taui * qxi - tauj * qxj ) ** 2 / ( 4.0d0 * r2 )
     +              - ( si   * qyi - sj   * qyj ) ** 2 / ( 4.0d0 * r2 )

          if ( c .gt. 0.0d0 ) then

              tmpa = - ( taui * qxi - tauj * qxj ) / ( 2.0d0 * r2 )
              tmpb = - ( si * qyi - sj * qyj ) / ( 2.0d0 * r2 )

              dcdqxi =   tmpa * taui
              dcdqyi =   tmpb * si
              dcdsi  =   tmpa * ( b2 / a2 ) * qxi + tmpb * qyi

              dcdqxj = - tmpa * tauj
              dcdqyj = - tmpb * sj
              dcdsj  = - tmpa * ( b2 / a2 ) * qxj - tmpb * qyj

              g(3 * i - 2) = g(3 * i - 2) + c * dcdqxi
              g(3 * i - 1) = g(3 * i - 1) + c * dcdqyi
              g(3 * i    ) = g(3 * i    ) + c * dcdsi

              g(3 * j - 2) = g(3 * j - 2) + c * dcdqxj
              g(3 * j - 1) = g(3 * j - 1) + c * dcdqyj
              g(3 * j    ) = g(3 * j    ) + c * dcdsj

          end if

          j = next(j)
          go to 10
    

      end if

      end

C     ******************************************************************
C     ******************************************************************
 
      subroutine hnrdist(n,x,hlin,hcol,hval,hnnz,i,lstart)

      implicit none

C     SCALAR ARGUMENTS
      integer i,lstart,n,hnnz

C     ARRAY ARGUMENTS
      integer hcol(*),hlin(*)
      double precision hval(*),x(n)

#include "packdata.com"
#include "partdata.com"

C     COMMON ARRAYS
      double precision diagb(3*nitemax)

C     LOCAL SCALARS
      integer col,j,lin
      double precision c,qxi,qxj,qyi,qyj,si,sj,taui,tauj,tmpa,tmpb,
     +        dcdqxi,dcdqxj,dcdqyi,dcdqyj,dcdsi,dcdsj,dtmpadqxi,
     +        dtmpadsi,dtmpadqxj,dtmpadsj,dtmpbdqyi,dtmpbdsi,dtmpbdqyj,
     +        dtmpbdsj,dcdqxiqxi,dcdqxisi,dcdqxiqxj,dcdqxisj,dcdqyiqyi,
     +        dcdqyisi,dcdqyiqyj,dcdqyisj,dcdsisi,dcdsiqxj,dcdsiqyj,
     +        dcdsisj,dcdqxjqxj,dcdqxjsj,dcdqyjqyj,dcdqyjsj,dcdsjsj

C     COMMON BLOCKS
      common /diblocks/ diagb

      qxi = x( 3 * i - 2 )
      qyi = x( 3 * i - 1 )
      si  = x( 3 * i     )

      taui = 1.0d0 + ( si - 1.0d0 ) * ( b2 / a2 )

      j = lstart

 10   if ( j .ne. 0 ) then

          qxj = x( 3 * j - 2 )
          qyj = x( 3 * j - 1 )
          sj  = x( 3 * j     )

          tauj = 1.0d0 + ( sj - 1.0d0 ) * ( b2 / a2 )

          c = 1.0d0 - ( taui * qxi - tauj * qxj ) ** 2 / ( 4.0d0 * r2 )
     +              - ( si   * qyi - sj   * qyj ) ** 2 / ( 4.0d0 * r2 )

          if ( c .gt. 0.0d0 ) then

              tmpa = - ( taui * qxi - tauj * qxj ) / ( 2.0d0 * r2 )

              dtmpadqxi = - taui / ( 2.0d0 * r2 )
              dtmpadsi  = - ( b2 / a2 ) * qxi / ( 2.0d0 * r2 )
              dtmpadqxj =   tauj / ( 2.0d0 * r2 )
              dtmpadsj  =   ( b2 / a2 ) * qxj / ( 2.0d0 * r2 )

              tmpb = - ( si * qyi - sj * qyj ) / ( 2.0d0 * r2 )

              dtmpbdqyi = - si / ( 2.0d0 * r2 )
              dtmpbdsi  = - qyi / ( 2.0d0 * r2 )
              dtmpbdqyj =   sj / ( 2.0d0 * r2 )
              dtmpbdsj  =   qyj / ( 2.0d0 * r2 )

              dcdqxi = tmpa * taui

              dcdqxiqxi = dtmpadqxi * taui
              dcdqxisi  = dtmpadsi  * taui + tmpa * ( b2 / a2 )
              dcdqxiqxj = dtmpadqxj * taui
              dcdqxisj  = dtmpadsj  * taui

              dcdqyi = tmpb * si

              dcdqyiqyi = dtmpbdqyi * si
              dcdqyisi  = dtmpbdsi  * si + tmpb
              dcdqyiqyj = dtmpbdqyj * si
              dcdqyisj  = dtmpbdsj  * si

              dcdsi  = tmpa * ( b2 / a2 ) * qxi + tmpb * qyi

              dcdsisi  = dtmpadsi * ( b2 / a2 ) * qxi + dtmpbdsi * qyi
              dcdsiqxj = dtmpadqxj * ( b2 / a2 ) * qxi
              dcdsiqyj = dtmpbdqyj * qyi
              dcdsisj  = dtmpadsj * ( b2 / a2 ) * qxi + dtmpbdsj * qyi

              dcdqxj = - tmpa * tauj

              dcdqxjqxj = - dtmpadqxj * tauj
              dcdqxjsj  = - dtmpadsj * tauj - tmpa * ( b2 / a2 )

              dcdqyj = - tmpb * sj

              dcdqyjqyj = - dtmpbdqyj * sj
              dcdqyjsj  = - dtmpbdsj  * sj - tmpb

              dcdsj  = - tmpa * ( b2 / a2 ) * qxj - tmpb * qyj

              dcdsjsj  = - dtmpadsj  * ( b2 / a2 ) * qxj - dtmpbdsj *qyj

c             ind1 = min( i, j )
c             ind2 = max( i, j )

c             g(3 * i - 2) = g(3 * i - 2) + c * dcdqxi

c             hlin() = 3 * i - 2
c             hcol() = 3 * i - 2
c             hval() = dcdqxi ** 2 + c * dcdqxiqxi
            
              diagb(3 * i - 2) = 
     +        diagb(3 * i - 2) + dcdqxi ** 2 + c * dcdqxiqxi

c             g(3 * i - 1) = g(3 * i - 1) + c * dcdqyi

              hlin(hnnz + 1) = 3 * i - 1
              hcol(hnnz + 1) = 3 * i - 2
              hval(hnnz + 1) = dcdqxi * dcdqyi

c             hlin() = 3 * i - 1
c             hcol() = 3 * i - 1
c             hval() = dcdqyi ** 2 + c * dcdqyiqyi

              diagb(3 * i - 1) = 
     +        diagb(3 * i - 1) + dcdqyi ** 2 + c * dcdqyiqyi

c             g(3 * i    ) = g(3 * i    ) + c * dcdsi

              hlin(hnnz + 2) = 3 * i
              hcol(hnnz + 2) = 3 * i - 2
              hval(hnnz + 2) = dcdqxi * dcdsi + c * dcdqxisi

              hlin(hnnz + 3) = 3 * i
              hcol(hnnz + 3) = 3 * i - 1
              hval(hnnz + 3) = dcdqyi * dcdsi + c * dcdqyisi
             
c             hlin() = 3 * i
c             hcol() = 3 * i
c             hval() = dcdsi ** 2 + c * dcdsisi

              diagb(3 * i) = 
     +        diagb(3 * i) + dcdsi ** 2 + c * dcdsisi

c             g(3 * j - 2) = g(3 * j - 2) + c * dcdqxj

              lin = 3 * j - 2
              col = 3 * i - 2
              if ( lin .lt. col ) call iswap(lin,col)
              hlin(hnnz + 4) = lin
              hcol(hnnz + 4) = col
              hval(hnnz + 4) = dcdqxi * dcdqxj + c * dcdqxiqxj

              lin = 3 * j - 2
              col = 3 * i - 1
              if ( lin .lt. col ) call iswap(lin,col)
              hlin(hnnz + 5) = lin
              hcol(hnnz + 5) = col
              hval(hnnz + 5) = dcdqyi * dcdqxj

              lin = 3 * j - 2
              col = 3 * i
              if ( lin .lt. col ) call iswap(lin,col)
              hlin(hnnz + 6) = lin
              hcol(hnnz + 6) = col
              hval(hnnz + 6) = dcdsi * dcdqxj + c * dcdsiqxj

c             hlin() = 3 * j - 2
c             hcol() = 3 * j - 2
c             hval() = dcdqxj ** 2 + c * dcdqxjqxj

              diagb(3 * j - 2) = 
     +        diagb(3 * j - 2) + dcdqxj ** 2 + c * dcdqxjqxj

c             g(3 * j - 1) = g(3 * j - 1) + c * dcdqyj

              lin = 3 * j - 1
              col = 3 * i - 2
              if ( lin .lt. col ) call iswap(lin,col)
              hlin(hnnz + 7) = lin
              hcol(hnnz + 7) = col
              hval(hnnz + 7) = dcdqxi * dcdqyj

              lin = 3 * j - 1
              col = 3 * i - 1
              if ( lin .lt. col ) call iswap(lin,col)
              hlin(hnnz + 8) = lin
              hcol(hnnz + 8) = col
              hval(hnnz + 8) = dcdqyi * dcdqyj + c * dcdqyiqyj

              lin = 3 * j - 1
              col = 3 * i
              if ( lin .lt. col ) call iswap(lin,col)
              hlin(hnnz + 9) = lin
              hcol(hnnz + 9) = col
              hval(hnnz + 9) = dcdsi * dcdqyj + c * dcdsiqyj

              hlin(hnnz + 10) = 3 * j - 1
              hcol(hnnz + 10) = 3 * j - 2
              hval(hnnz + 10) = dcdqxj * dcdqyj

c             hlin() = 3 * j - 1
c             hcol() = 3 * j - 1
c             hval() = dcdqyj ** 2 + c * dcdqyjqyj

              diagb(3 * j - 1) = 
     +        diagb(3 * j - 1) + dcdqyj ** 2 + c * dcdqyjqyj

c             g(3 * j    ) = g(3 * j    ) + c * dcdsj

              lin = 3 * j
              col = 3 * i - 2
              if ( lin .lt. col ) call iswap(lin,col)
              hlin(hnnz + 11) = lin
              hcol(hnnz + 11) = col
              hval(hnnz + 11) = dcdqxi * dcdsj + c * dcdqxisj

              lin = 3 * j
              col = 3 * i - 1
              if ( lin .lt. col ) call iswap(lin,col)
              hlin(hnnz + 12) = lin
              hcol(hnnz + 12) = col
              hval(hnnz + 12) = dcdqyi * dcdsj + c * dcdqyisj

              lin = 3 * j
              col = 3 * i
              if ( lin .lt. col ) call iswap(lin,col)
              hlin(hnnz + 13) = lin
              hcol(hnnz + 13) = col
              hval(hnnz + 13) = dcdsi * dcdsj + c * dcdsisj

              hlin(hnnz + 14) = 3 * j
              hcol(hnnz + 14) = 3 * j - 2
              hval(hnnz + 14) = dcdqxj * dcdsj + c * dcdqxjsj

              hlin(hnnz + 15) = 3 * j
              hcol(hnnz + 15) = 3 * j - 1
              hval(hnnz + 15) = dcdqyj * dcdsj + c * dcdqyjsj

c             hlin() = 3 * j
c             hcol() = 3 * j
c             hval() = dcdsj ** 2 + c * dcdsjsj

              diagb(3 * j) = 
     +        diagb(3 * j) + dcdsj ** 2 + c * dcdsjsj

              hnnz = hnnz + 15
                 
          end if

          j = next(j)
          go to 10

      end if

      end

C     ******************************************************************
C     ******************************************************************
 
      subroutine classify(n,x)

      implicit none

C     SCALAR ARGUMENTS
      integer n

C     ARRAY ARGUMENTS
      double precision x(n)

#include "packdata.com"
#include "partdata.com"

C     LOCAL SCALARS
      integer i,j,k
      double precision qx,qy,s,xx,yy

C     CLEAN-UP THE START STRUCTURE

      do k = 1,nbr
          i = br(1,k)
          j = br(2,k)
          start(i,j) = 0
      end do

C     FILL-IN THE START STRUCTURE AGAIN

      nbr = 0
      do k = 1,nite
          qx = x( 3 * k - 2 )
          qy = x( 3 * k - 1 )
          s  = x( 3 * k     )

          xx = ( 1.0d0 + ( s - 1.0d0 ) * ( b2 / a2 ) ) * qx
          yy = s * qy

          call region(nrega,nregb,xx,yy,i,j)

          if ( start(i,j) .eq. 0 ) then
              nbr = nbr + 1
              br(1,nbr) = i
              br(2,nbr) = j
          end if

          next(k) = start(i,j)
          start(i,j) = k
      end do
 
      end

C     ******************************************************************
C     ******************************************************************
 
      subroutine region(nrega,nregb,x,y,i,j)

      implicit none

C     SCALAR ARGUMENTS
      integer i,j,nrega,nregb
      double precision x,y

#include "packdata.com"

C     LOCAL SCALARS
      double precision r

      r = sqrt( r2 )

      i = 1 + int( ( x + nrega * r ) / ( 2.0d0 * r ) )
      i = min( max( 1, i ), nrega )

      j = 1 + int( ( y + nregb * r ) / ( 2.0d0 * r ) )
      j = min( max( 1, j ), nregb )

      end

C     ******************************************************************
C     ******************************************************************
 
      integer function ceil(x)

      implicit none

C     SCALAR ARGUMENTS
      double precision x

      if ( x .eq. int( x ) ) then
          ceil = int( x )
      else
          ceil = int( x + 1 )
      end if

      end

C     ******************************************************************
C     ******************************************************************
 
      subroutine iswap(a,b)

C     SCALAR ARGUMENTS
      integer a,b

C     LOCAL SCALARS
      integer tmp

      tmp = a
      a   = b
      b   = tmp

      end

C     ******************************************************************
C     ******************************************************************

      subroutine evalc(n,x,ind,c,flag)

      implicit none

C     SCALAR ARGUMENTS
      integer ind,flag,n
      double precision c

C     ARRAY ARGUMENTS
      double precision x(n)

      flag = - 1

      end

C     ******************************************************************
C     ******************************************************************

      subroutine evaljac(n,x,ind,jcvar,jcval,jcnnz,flag)

      implicit none

C     SCALAR ARGUMENTS
      integer flag,ind,n,jcnnz

C     ARRAY ARGUMENTS
      integer jcvar(n)
      double precision x(n),jcval(n)

      flag = - 1

      end

C     ******************************************************************
C     ******************************************************************

      subroutine evalhc(n,x,ind,hclin,hccol,hcval,hcnnz,flag)

      implicit none

C     SCALAR ARGUMENTS
      integer flag,ind,n,hcnnz

C     ARRAY ARGUMENTS
      integer hccol(*),hclin(*)
      double precision hcval(*),x(n)

      flag = - 1

      end

C     ******************************************************************
C     ******************************************************************

      subroutine evalfc(n,x,f,m,c,flag)

      implicit none

C     SCALAR ARGUMENTS
      integer flag,m,n
      double precision f

C     ARRAY ARGUMENTS
      double precision c(m),x(n)

      flag = - 1

      end

C     ******************************************************************
C     ******************************************************************

      subroutine evalgjac(n,x,g,m,jcfun,jcvar,jcval,jcnnz,flag)

      implicit none

C     SCALAR ARGUMENTS
      integer flag,jcnnz,m,n

C     ARRAY ARGUMENTS
      integer jcfun(*),jcvar(*)
      double precision g(n),jcval(*),x(n)

      flag = - 1

      end

C     ******************************************************************
C     ******************************************************************

      subroutine evalhl(n,x,m,lambda,scalef,scalec,hllin,hlcol,hlval,
     +hlnnz,flag)

      implicit none

C     SCALAR ARGUMENTS
      integer flag,hlnnz,m,n
      double precision scalef

C     ARRAY ARGUMENTS
      integer hlcol(*),hllin(*)
      double precision hlval(*),lambda(m),scalec(m),x(n)

      flag = - 1

      end

C     ******************************************************************
C     ******************************************************************

      subroutine evalhlp(n,x,m,lambda,scalef,scalec,p,hp,goth,flag)

      implicit none

C     SCALAR ARGUMENTS
      logical goth
      integer flag,m,n
      double precision scalef

C     ARRAY ARGUMENTS
      double precision hp(n),lambda(m),p(n),scalec(m),x(n)

      flag = - 1

      end

C     ******************************************************************
C     ******************************************************************

      subroutine endp(n,x,l,u,m,lambda,equatn,linear)

      implicit none

C     SCALAR ARGUMENTS
      integer m,n

C     ARRAY ARGUMENTS
      logical equatn(m),linear(m)
      double precision l(n),lambda(m),u(n),x(n)

      end

C     ******************************************************************
C     ******************************************************************

      double precision function cmax(n,x)

      implicit none

C     SCALAR ARGUMENTS
      integer n

C     ARRAY ARGUMENTS
      double precision x(n)

#include "packdata.com"
#include "partdata.com"

C     LOCAL SCALARS
      integer i,j,k,l
      double precision belong,c1,c2,overlap,qx,qy,s

C     EXTERNAL FUNCTIONS
      double precision nrdistmax
      external nrdistmax

C     CLASSIFY ITEMS BY REGIONS

      call classify(n,x)
 
C     COMPUTE SPARSE OVERLAPPING

      cmax = 0.0d0

      do k = 1,nbr
          i = br(1,k)
          j = br(2,k)
          l = start(i,j)
 10       if ( l .ne. 0 ) then
              overlap = 0.0d0
              overlap = max( overlap, nrdistmax(n,x,l,start(i  ,j))   )
              overlap = max( overlap, nrdistmax(n,x,l,start(i-1,j))   )
              overlap = max( overlap, nrdistmax(n,x,l,start(i-1,j+1)) )
              overlap = max( overlap, nrdistmax(n,x,l,start(i  ,j+1)) )
              overlap = max( overlap, nrdistmax(n,x,l,start(i+1,j+1)) )
              overlap = max( overlap, nrdistmax(n,x,l,start(i+1,j  )) )
              overlap = max( overlap, nrdistmax(n,x,l,start(i+1,j-1)) )
              overlap = max( overlap, nrdistmax(n,x,l,start(i  ,j-1)) )
              overlap = max( overlap, nrdistmax(n,x,l,start(i-1,j-1)) )

              qx = x( 3 * l - 2 )
              qy = x( 3 * l - 1 )
              s  = x( 3 * l     )

              c1 = 1.0d0 - ( s - 1.0d0 ) ** 2 * 
     +                     ( ( b2 / a2 ) ** 2 * qx ** 2 + qy ** 2 ) / r2

              c2 = qx ** 2 / a2 + qy ** 2 / b2 - 1.0d0

              belong =  max ( max( 0.0d0, c1 ), abs( c2 ) )

              cmax = max( cmax, max( overlap, belong ) )

              l = next(l)
              go to 10
          end if
      end do

      return

      end

C     ******************************************************************
C     ******************************************************************
 
      double precision function nrdistmax(n,x,i,lstart)

      implicit none

C     SCALAR ARGUMENTS
      integer i,lstart,n

C     ARRAY ARGUMENTS
      double precision x(n)

#include "packdata.com"
#include "partdata.com"

C     LOCAL SCALARS
      integer j
      double precision c,qxi,qxj,qyi,qyj,si,sj,taui,tauj

      nrdistmax = 0.0d0

      qxi = x( 3 * i - 2 )
      qyi = x( 3 * i - 1 )
      si  = x( 3 * i     )

      taui = 1.0d0 + ( si - 1.0d0 ) * ( b2 / a2 )

      j = lstart

 10   if ( j .ne. 0 ) then
          if ( j .ne. i ) then
              qxj = x( 3 * j - 2 )
              qyj = x( 3 * j - 1 )
              sj  = x( 3 * j     )

              tauj = 1.0d0 + ( sj - 1.0d0 ) * ( b2 / a2 )

              c = 1.0d0 
     +          - ( taui * qxi - tauj * qxj ) ** 2 / ( 4.0d0 * r2 )
     +          - ( si   * qyi - sj   * qyj ) ** 2 / ( 4.0d0 * r2 )

              nrdistmax = max( nrdistmax, max( 0.0d0, c ) )
          end if

          j = next(j)
          go to 10
      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine cindmax(n,x,cindmaxv,cindmaxi)

      implicit none

C     SCALAR ARGUMENTS
      integer cindmaxi,n
      double precision cindmaxv

C     ARRAY ARGUMENTS
      double precision x(n)

#include "packdata.com"
#include "partdata.com"

C     LOCAL SCALARS
      integer i,j,k,l
      double precision belong,c1,c2,cindv,overlap,qx,qy,s

C     EXTERNAL FUNCTIONS
      double precision nrdistsum
      external nrdistsum

C     CLASSIFY ITEMS BY REGIONS

      call classify(n,x)
 
C     COMPUTE SPARSE OVERLAPPING

      cindmaxv = 0.0d0
      cindmaxi = 0

      do k = 1,nbr
          i = br(1,k)
          j = br(2,k)
          l = start(i,j)
 10       if ( l .ne. 0 ) then
              overlap = nrdistsum(n,x,l,start(i  ,j))     + 
     +                  nrdistsum(n,x,l,start(i-1,j))     + 
     +                  nrdistsum(n,x,l,start(i-1,j+1))   + 
     +                  nrdistsum(n,x,l,start(i  ,j+1))   + 
     +                  nrdistsum(n,x,l,start(i+1,j+1))   + 
     +                  nrdistsum(n,x,l,start(i+1,j  ))   + 
     +                  nrdistsum(n,x,l,start(i+1,j-1))   + 
     +                  nrdistsum(n,x,l,start(i  ,j-1))   + 
     +                  nrdistsum(n,x,l,start(i-1,j-1))

              qx = x( 3 * l - 2 )
              qy = x( 3 * l - 1 )
              s  = x( 3 * l     )

              c1 = 1.0d0 - ( s - 1.0d0 ) ** 2 * 
     +                     ( ( b2 / a2 ) ** 2 * qx ** 2 + qy ** 2 ) / r2

              c2 = qx ** 2 / a2 + qy ** 2 / b2 - 1.0d0

              belong = 0.5d0 * max( 0.0d0, c1 ) ** 2 + 0.5d0 * c2 ** 2

              cindv = overlap + belong

              if ( cindv .ge. cindmaxv ) then
                  cindmaxv = cindv
                  cindmaxi = l
              end if

              l = next(l)
              go to 10
          end if
      end do

      end

C     ******************************************************************
C     ******************************************************************
 
      double precision function nrdistsum(n,x,i,lstart)

      implicit none

C     SCALAR ARGUMENTS
      integer i,lstart,n

C     ARRAY ARGUMENTS
      double precision x(n)

#include "packdata.com"
#include "partdata.com"

C     LOCAL SCALARS
      integer j
      double precision c,qxi,qxj,qyi,qyj,si,sj,taui,tauj

      nrdistsum = 0.0d0

      qxi = x( 3 * i - 2 )
      qyi = x( 3 * i - 1 )
      si  = x( 3 * i     )

      taui = 1.0d0 + ( si - 1.0d0 ) * ( b2 / a2 )

      j = lstart

 10   if ( j .ne. 0 ) then
          if ( j .ne. i ) then
              qxj = x( 3 * j - 2 )
              qyj = x( 3 * j - 1 )
              sj  = x( 3 * j     )

              tauj = 1.0d0 + ( sj - 1.0d0 ) * ( b2 / a2 )

              c = 1.0d0 
     +          - ( taui * qxi - tauj * qxj ) ** 2 / ( 4.0d0 * r2 )
     +          - ( si   * qyi - sj   * qyj ) ** 2 / ( 4.0d0 * r2 )

              nrdistsum = nrdistsum + 0.5d0 * max( 0.0d0, c ) ** 2
          end if

          j = next(j)
          go to 10
      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine algencan(epsfeas,epsopt,iprint,ncomp,n,x,l,u,m,lambda,
     +equatn,linear,coded,checkder,fu,cnormu,snorm,nlpsupn,inform)

      implicit none

C     SCALAR ARGUMENTS
      logical checkder
      integer inform,iprint,m,n,ncomp
      double precision cnormu,epsfeas,epsopt,fu,nlpsupn,snorm

C     ARRAY ARGUMENTS
      logical coded(10),equatn(m),linear(m)
      double precision l(n),lambda(m),u(n),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      double precision bignum,macheps,macheps12,macheps13,macheps23

C     COMMON BLOCKS
      common /machcon/ bignum,macheps,macheps12,macheps13,macheps23
      save   /machcon/
C     PARAMETERS

C     General constants

      double precision fmin

      parameter ( fmin       = - 1.0d+20 )

C     Line search constants

      integer maxextrap,mininterp
      double precision beta,etaint,etaext,gamma,sigma1,sigma2

      parameter ( maxextrap  =       100 )
      parameter ( mininterp  =         4 )

      parameter ( gamma      =   1.0d-04 )
      parameter ( beta       =     0.5d0 )
      parameter ( sigma1     =     0.1d0 )
      parameter ( sigma2     =     0.9d0 )
      parameter ( etaint     =     2.0d0 )
      parameter ( etaext     =     2.0d0 )

C     Safeguarding spectral step constants

      double precision lspgma,lspgmi

      parameter ( lspgma     =   1.0d+10 )
      parameter ( lspgmi     =   1.0d-10 )

C     Conjugate gradients constants

      integer maxcgitnp
      double precision epsnqmp,theta

      parameter ( theta      =   1.0d-06 )
      parameter ( epsnqmp    =   1.0d-08 )
      parameter ( maxcgitnp  =         5 )

C     BETRA constants

      logical extrp4,extrp5
      integer msmaxit
      double precision mseps,msrho,mssig,phieps,trdelini,trdelmin,
     +        tralpha

      parameter ( extrp4     =   .true. )
      parameter ( extrp5     =   .true. )

      parameter ( msmaxit    =       20 )

      parameter ( mseps      =  1.0d-08 )
      parameter ( mssig      =  1.0d-01 )
      parameter ( msrho      =  9.0d-01 )
      parameter ( phieps     =  1.0d-08 )
      parameter ( trdelini   =  1.0d+02 )
      parameter ( trdelmin   =  1.0d-08 )
      parameter ( tralpha    =  1.0d-01 )

C     GENCAN constants

      integer maxinnitnp
      double precision cggpnf,cgepsi,cgepsf,delmin,eta

      parameter ( maxinnitnp =         3 )
      parameter ( delmin     =   1.0d+04 )
      parameter ( eta        =   0.1d0   )
      parameter ( cggpnf     =   1.0d-04 )
      parameter ( cgepsi     =   1.0d-01 )
      parameter ( cgepsf     =   1.0d-08 )

C     ALGENCAN constants

      logical rhorestart
      integer maxoutitnp,maxoutit
      double precision lammax,lammin,rhofrac,rhoinimax,rhoinimin,rhomax,
     +        rhomult

      parameter ( maxoutitnp =        10 )
      parameter ( maxoutit   =       100 )

      parameter ( lammin     = - 1.0d+20 )
      parameter ( lammax     =   1.0d+20 )

      parameter ( rhofrac    =   0.5d0   )
      parameter ( rhomult    =   1.0d+01 )
      parameter ( rhomax     =   1.0d+20 )

      parameter ( rhorestart =    .true. )
      parameter ( rhoinimin  =   1.0d-08 )
      parameter ( rhoinimax  =   1.0d+08 )
C     COMMON SCALARS
      integer efcnt,efccnt,egcnt,egjccnt,ehcnt,ehlcnt,ehlpcnt,fcnt

C     COMMON ARRAYS
      integer eccnt(mmax),ehccnt(mmax),ejccnt(mmax)

C     COMMON BLOCKS
      common /counters/ eccnt,ehccnt,ejccnt,efcnt,efccnt,egcnt,egjccnt,
     +                  ehcnt,ehlcnt,ehlpcnt,fcnt
      save   /counters/
C     COMMON SCALARS
      logical iprintctl(7)
      integer iprintinn,iprintout,mprint,nprint

C     COMMON BLOCKS
      common /outdat/ iprintctl,iprintinn,iprintout,nprint,mprint
      save   /outdat/

C     COMMON SCALARS
      character * 6 hptype
      character * 2 innslvr
      logical ccoded,fccoded,fcoded,gcoded,gjaccoded,innercall,jaccoded,
     +        hcoded,hccoded,hlcoded,hlpcoded,firstde,truehl,ignoref,
     +        skipacc,sclsys,useustp,safemode

C     COMMON BLOCKS
      common /algparam/ fcoded,gcoded,hcoded,ccoded,jaccoded,hccoded,
     +                  hlcoded,hlpcoded,fccoded,gjaccoded,firstde,
     +                  truehl,ignoref,skipacc,sclsys,innercall,useustp,
     +                  innslvr,hptype,safemode
      save   /algparam/
C     COMMON SCALARS
      logical scale
      double precision sf,usf

C     COMMON ARRAYS
      double precision sc(mmax),usc(mmax)

C     COMMON BLOCK
      common /scadat/ sc,usc,sf,usf,scale
      save   /scadat/
C     COMMON SCALARS
      logical slacks
      integer nws

C     COMMON ARRAYS
      integer slaind(mmax)

C     COMMON BLOCKS
      common /sladat/ slaind,nws,slacks
      save   /sladat/
C     COMMON SCALARS
      logical rmfixv,yset

C     COMMON ARRAYS
      integer ycor(nmax),yind(0:nmax)
      double precision y(nmax)

C     COMMON BLOCKS
      common /fixvar/ y,ycor,yind,yset,rmfixv
      save   /fixvar/

C     PARAMETERS
      integer n0,n1,n2
      parameter ( n0 =   500 )
      parameter ( n1 = 10000 )
      parameter ( n2 = 20000 )

C     LOCAL SCALARS
      logical innfail,lss,scl
      integer alinfo,fcsubt,geninfo,i,iter,j,maxit,nwcalls,nwtotit,
     +        oprint,outiter,solinfo,totiter,msqcalls,msqtotit,toteccnt,
     +        totejccnt,totehccnt,aveeccnt,aveejccnt,aveehccnt
      double precision cnorm,cnormb,cnormub,f,fb,fub,ncsupn,nlpsupnb,
     +        rsupn
      real time

C     LOCAL ARRAYS
      character * 4 lsssub,sclsub
      double precision nl(nmax),c(mmax),cu(mmax),rho(mmax)
      real dum(2)

C     DATA STATEMENTS
      data dum/0.0,0.0/

C     EXTERNAL FUNCTIONS AND SUBROUTINES
      external fparam,checkd,auglag,gencan,lss,scl

C     ==================================================================
C     Start timing
C     ==================================================================

      time = dtime(dum)

C     ==================================================================
C     Set safety mode
C     ==================================================================

      safemode = .false.

C     ==================================================================
C     Initialization
C     ==================================================================

C     Set machine-dependent constants

      bignum    = 1.0d+99
      macheps   = 1.0d-16
      macheps12 = sqrt( macheps )
      macheps13 = macheps ** ( 1.0d0 / 3.0d0 )
      macheps23 = macheps ** ( 2.0d0 / 3.0d0 )

C     Set global counters

      fcnt    = 0
      efcnt   = 0
      efccnt  = 0
      egcnt   = 0
      egjccnt = 0
      ehcnt   = 0
      ehlcnt  = 0
      ehlpcnt = 0

      do j = 1,m
          eccnt(j)  = 0
          ejccnt(j) = 0
          ehccnt(j) = 0
      end do

C     ==================================================================
C     Check user provided subroutines
C     ==================================================================

C     Set user-provided subroutines indicators

      fcoded    = coded(1)
      gcoded    = coded(2)
      hcoded    = coded(3)
      ccoded    = coded(4)
      jaccoded  = coded(5)
      hccoded   = coded(6)
      fccoded   = coded(7)
      gjaccoded = coded(8)
      hlcoded   = coded(9)
      hlpcoded  = coded(10)

C     Check whether mandatory subroutines are being properly provided

C     For unconstrained and bound-constrained problems, EVALF must be 
C     coded by the user. For constrained problems, EVALF and EVALC, or, 
C     alternatively, EVALFC must be coded. (Note that EVALF/EVALC and 
C     EVALFC should not be provided concurrently.) For feasibility 
C     problems, a constant null objective function must be coded and the 
C     problem solved with the IGNORE-OBJECTIVE-FUNCTION keyword. Coded 
C     subroutines must be indicated by setting the entrances of array 
C     named CODED within subroutine INIP.

      fcsubt = 0      
      if ( fcoded .and. ( ccoded .or. m .eq. 0 ) ) then
          fcsubt = 1
      else if ( fccoded ) then
          fcsubt = 2
      end if

C     Check whether first-order subroutines are being properly provided

C     If EVALF was coded to compute the objective function, its gradient 
C     must be provided within EVALG subroutine. If EVALC was coded to 
C     compute the constraints individualy, gradients of the constraints 
C     must be coded within subroutine EVALJAC. If EVALFC was coded to 
C     compute the objective function and all the constraints at once, 
C     the gradient of the objective function and the Jacobian of the 
C     constraints must be provided within subroutine EVALGJAC. If other 
C     combination is coded, first derivatives are ignored.

      firstde = .false.
      if ( ( fcsubt .eq. 1 .and. gcoded .and. ( jaccoded .or. 
     +     m .eq. 0 ) ) .or. ( fcsubt .eq. 2 .and. gjaccoded ) ) then
          firstde = .true.
      end if

C     Check whether the true Hessian of the Lagrangian can be computed

      truehl = .false.
      if ( hlcoded .or. ( hcoded .and. ( hccoded .or. m.eq.0 ) ) ) then
          truehl = .true.
      end if

C     ==================================================================
C     Set default values for algoritmic parameters
C     ==================================================================

C     Hessian-vector product strategy: HAPPRO, INCQUO or TRUEHP. TRUEHP
C     is the default option. If the proper subroutines were not coded by
C     the user, then HAPPRO is used instead. HAPPRO reduces to INCQUO in
C     the unconstrained and bound-constrained cases and switches between
C     INCQUO and the product by an approximation of the Hessian in the
C     constrained case.

      if ( truehl .or. hlpcoded ) then
          hptype = 'TRUEHP'
      else
          hptype = 'HAPPRO'
      end if

C     Inner solver method: TR (trust regions, i.e. BETRA), NW (Newtonian
C     system with the use of a direct solver, i.e. MA57AD), TN + TRUEHP
C     (Truncated Newton and true Hessian-vector product) or TN + HAPPRO
C     (Truncated Newton and product with Hessian approximation). If the
C     proper subroutines were not provided by the user then TN + HAPPRO
C     is used.

      if ( truehl .and. lss(lsssub) .and. n .le. n0 ) then
          innslvr = 'TR'
      else if ( truehl .and. lss(lsssub) .and. n .le. n1 ) then
          innslvr = 'NW'
      else
          innslvr = 'TN'
          if ( n .gt. n2 ) then
              hptype  = 'HAPPRO'
          end if
      end if

C     For this particular problem ...
      hptype  = 'TRUEHP'
      innslvr = 'TN'

C     Scaling of linear systems

      if ( lsssub .eq. 'MA57' .or. scl(sclsub) ) then
          sclsys = .true.
      else
          sclsys = .false.
      end if

C     Ignore objective function (to only find a feasible point by
C     minimizing 1/2 of the squared infeasibility)
      ignoref = .false.

C     Acceleration step
      if ( truehl .and. lss(lsssub) ) then
          skipacc = .false.
      else
          skipacc = .true.
      end if

C     Slacks for inequality constraints
      slacks = .false.

C     Remove fixed variables (with identical lower and upper bounds)
      rmfixv = .true.

C     Scale objective function and constraints
      if ( m .gt. 0 .and. .not. ignoref ) then
          scale = .true.
      else
          scale = .false.
      end if

C     Flags used to make inner calls to Gencan
      innercall = .false.
      useustp   = .true.

C     ==================================================================
C     Main output control (silent-mode?)
C     ==================================================================

      iprintctl(1) = .true. ! Banner
      iprintctl(2) = .true. ! Parameters and problem processing
      iprintctl(3) = .true. ! Warnings and errors messages
      iprintctl(4) = .true. ! Screen-mirror file algencan.out
      iprintctl(5) = .true. ! Solution file solution.txt
      iprintctl(6) = .true. ! User-provided subs calls counters and timing
      iprintctl(7) = .true. ! Statistic files with table lines

      oprint = iprint

      open(10,err=100,file='.silent',status='old')
      close(10)

      do i = 1,6
          iprintctl(i) = .false.
      end do

      oprint = 0

 100  continue

      if ( iprintctl(4) ) then
          open(unit=10,file='algencan.out',status='replace')
      else
          open(unit=10,                    status='scratch')
      end if

C     ==================================================================
C     Set solver arguments using the specification file
C     ==================================================================

      call fparam(epsfeas,epsopt,oprint,ncomp)

C     Outer and inner iterations output detail

      iprintout = oprint / 10
      iprintinn = mod( oprint, 10 )

C     Error tracker

      inform = 0

C     Stop if mandatory subroutines were not properly provided

      if ( fcsubt .eq. 0 ) then
          if ( iprintctl(3) ) then
              write(* ,1000)
              write(10,1000)
          end if

          if ( safemode ) then
              inform = - 88
              call reperr(inform)
              return
          end if
      end if

C     ==================================================================
C     Initialize problem data structures
C     ==================================================================

      call sinip(n,x,l,u,m,lambda,equatn,linear,coded,checkder,inform)
      if ( inform .lt. 0 ) return

      nprint = min( n, ncomp )
      mprint = min( m, ncomp )

C     ==================================================================
C     Call the solver
C     ==================================================================

C     ALGENCAN for PNL problems

      if ( .not. ignoref .and. m .gt. 0 ) then
          call auglag(n,x,l,u,m,lambda,equatn,linear,epsfeas,epsopt,f,c,
     +    cnorm,snorm,nl,nlpsupn,fu,cu,cnormu,fub,cnormub,fb,cnormb,
     +    nlpsupnb,ncsupn,rsupn,outiter,totiter,nwcalls,nwtotit,
     +    msqcalls,msqtotit,innfail,alinfo,inform)

          solinfo = alinfo

C     GENCAN for box-constrained problems and feasibility problems

      else
c         maxit = 999999999
          maxit = 100000

C         Used in feasibility problems (ignoref=true). With lambda=0 and
C         rho=1, to minimize 1/2 of the squared infeasibility coincides
C         with minimizing the augmented Lagrangian.
          do j = 1,m
              lambda(j) = 0.0d0
              rho(j)    = 1.0d0
          end do

          call gencan(n,x,l,u,m,lambda,equatn,linear,rho,epsfeas,epsopt,
     +    maxit,iter,f,nl,nlpsupn,cnorm,cnormu,geninfo,inform)

          solinfo  = geninfo

          ncsupn   = 0.0d0
          rsupn    = 0.0d0

          outiter  = 0
          totiter  = iter
          nwcalls  = 0
          nwtotit  = 0
          msqcalls = 0
          msqtotit = 0
          innfail  = .false.

          if ( ignoref ) then
              f = 0.0d0
          end if
          fu = f

          fb       = f
          fub      = fu
          cnormb   = cnorm
          cnormub  = cnormu
          nlpsupnb = nlpsupn
      end if

      if ( inform .lt. 0 ) return

C     ==================================================================
C     End problem data structures
C     ==================================================================

      call sendp(n,x,l,u,m,lambda,equatn,linear,inform)
      if ( inform .lt. 0 ) return

C     ==================================================================
C     Close output file
C     ==================================================================

      close(10)

C     ==================================================================
C     Stop timing
C     ==================================================================

      time = dtime(dum)
      time = dum(1)

C     ==================================================================
C     Write statistics
C     ==================================================================

      if ( iprintctl(6) ) then
          write(*,9000) time

          toteccnt  = 0
          totejccnt = 0
          totehccnt = 0

          do j = 1,m
              toteccnt  = toteccnt  + eccnt(j)
              totejccnt = totejccnt + ejccnt(j)
              totehccnt = totehccnt + ehccnt(j)
          end do

          if ( m .gt. 0 ) then
              aveeccnt  = toteccnt  / m
              aveejccnt = totejccnt / m
              aveehccnt = totehccnt / m
          else
              aveeccnt  = 0
              aveejccnt = 0
              aveehccnt = 0
          end if

          write(*,9010) fcoded,efcnt,gcoded,egcnt,hcoded,ehcnt,ccoded,
     +                  toteccnt,aveeccnt,jaccoded,totejccnt,aveejccnt,
     +                  hccoded,totehccnt,aveehccnt,fccoded,efccnt,
     +                  gjaccoded,egjccnt,hlcoded,ehlcnt,hlpcoded,
     +                  ehlpcnt
      end if

      if ( iprintctl(7) ) then
          open(20,file='algencan-tabline.out')
          write(20,9040) fu,cnormu,f,cnorm,nlpsupn,fub,cnormub,fb,
     +                   cnormb,nlpsupnb,ncsupn,rsupn,inform,solinfo,
     +                   innfail,n,m,outiter,totiter,fcnt,nwcalls,
     +                   nwtotit,msqcalls,msqtotit,time
          close(20)
      end if

C     ==================================================================
C     NON-EXECUTABLE STATEMENTS
C     ==================================================================

 1000 format(/,1X,'*** Mandatory subroutines are not being ',
     +            'provided properly ***',/,1X,'For unconstrained and ',
     +            'bound-constrained problems, EVALF must be coded by ',
     +            'the',/,1X,'user. For constrained problems, EVALF ',
     +            'and EVALC, or, alternatively, EVALFC',/,1X,'must ',
     +            'be coded. (Note that EVALF/EVALC and EVALFC should ',
     +            'not be provided',/,1X,'concurrently.) For ',
     +            'feasibility problems, a constant ',
     +            'null objective function',/,1X,'must be coded and ',
     +            'the problem solved with the ',
     +            'IGNORE-OBJECTIVE-FUNCTION',/,1X,'keyword. Coded ',
     +            'subroutines must be indicated by setting ',
     +            'the entrances of array',/,1X,'named CODED ',
     +            'within subroutine INIP.')
 9000 format(/,1X,'Total CPU time in seconds: ',F8.2)
 9010 format(/,1X,'User-provided subroutines calls counters: ',/,
     +       /,1X,'Subroutine evalf    (coded=',L1,'): ',I6,
     +       /,1X,'Subroutine evalg    (coded=',L1,'): ',I6,
     +       /,1X,'Subroutine evalh    (coded=',L1,'): ',I6,
     +       /,1X,'Subroutine evalc    (coded=',L1,'): ',I6,
     +         1X,'(',I6,' calls per constraint in average)',
     +       /,1X,'Subroutine evaljac  (coded=',L1,'): ',I6,
     +         1X,'(',I6,' calls per constraint in average)',
     +       /,1X,'Subroutine evalhc   (coded=',L1,'): ',I6,
     +         1X,'(',I6,' calls per constraint in average)',
     +       /,1X,'Subroutine evalfc   (coded=',L1,'): ',I6,
     +       /,1X,'Subroutine evalgjac (coded=',L1,'): ',I6,
     +       /,1X,'Subroutine evalhl   (coded=',L1,'): ',I6,
     +       /,1X,'Subroutine evalhlp  (coded=',L1,'): ',I6,/)
 9040 format(1X,1P,D24.16,1X,1P,D7.1,1X,1P,D24.16,1X,1P,D7.1,1X,1P,D7.1,
     +       1X,1P,D24.16,1X,1P,D7.1,1X,1P,D24.16,1X,1P,D7.1,1X,1P,D7.1,
     +       1X,1P,D7.1,1X,1P,D7.1,1X,I3,1X,I1,1X,L1,1X,I6,1X,I6,1X,I3,
     +       1X,I7,1X,I7,1X,I2,1X,I7,1X,I7,1X,I7,0P,F8.2)

      end
C     ******************************************************************
C     ******************************************************************

      subroutine auglag(n,x,l,u,m,lambda,equatn,linear,epsfeas,epsopt,
     +f,c,csupn,snorm,nl,nlpsupn,fu,cu,csupnu,fub,csupnub,fb,csupnb,
     +nlpsupnb,ncsupn,rsupn,outiter,totiter,nwcalls,nwtotit,msqcalls,
     +msqtotit,innfail,alinfo,inform)

      implicit none

C     SCALAR ARGUMENTS
      logical innfail
      integer alinfo,inform,m,msqcalls,msqtotit,n,nwcalls,nwtotit,
     +        outiter,totiter
      double precision csupn,csupnb,csupnu,csupnub,epsfeas,epsopt,f,fb,
     +        fu,fub,ncsupn,nlpsupn,nlpsupnb,rsupn,snorm

C     ARRAY ARGUMENTS
      logical equatn(m),linear(m)
      double precision c(m),cu(m),l(n),lambda(m),nl(n),u(n),x(n)

C     Solves the nonlinear programming problem
C
C     min f(x)
C
C     subject to
C
C             c_j(x)  = 0, j in E,
C             c_j(x) <= 0, j in I,
C             l <= x <= u,
C
C     where E is the set of indices of the equality constraints, I is
C     the set of indices of the inequality constraints, and there are
C     n variables and m constraints, using the method of multipliers
C     described in
C
C     R. Andreani, E. G. Birgin, J. M. Martínez and M. L. Schuverdt,
C     "On Augmented Lagrangian methods with general lower-level
C     constraints", SIAM Journal on Optimization 18, pp. 1286-1309, 2007.

C     alinfo:
C
C     0: Feasibility, optimality and complementarity satisfied
C     2: Too large penalty parameter. Infeasible problem?
C     3: Maximum number of algencan iterations reached

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      double precision bignum,macheps,macheps12,macheps13,macheps23

C     COMMON BLOCKS
      common /machcon/ bignum,macheps,macheps12,macheps13,macheps23
      save   /machcon/
C     PARAMETERS

C     General constants

      double precision fmin

      parameter ( fmin       = - 1.0d+20 )

C     Line search constants

      integer maxextrap,mininterp
      double precision beta,etaint,etaext,gamma,sigma1,sigma2

      parameter ( maxextrap  =       100 )
      parameter ( mininterp  =         4 )

      parameter ( gamma      =   1.0d-04 )
      parameter ( beta       =     0.5d0 )
      parameter ( sigma1     =     0.1d0 )
      parameter ( sigma2     =     0.9d0 )
      parameter ( etaint     =     2.0d0 )
      parameter ( etaext     =     2.0d0 )

C     Safeguarding spectral step constants

      double precision lspgma,lspgmi

      parameter ( lspgma     =   1.0d+10 )
      parameter ( lspgmi     =   1.0d-10 )

C     Conjugate gradients constants

      integer maxcgitnp
      double precision epsnqmp,theta

      parameter ( theta      =   1.0d-06 )
      parameter ( epsnqmp    =   1.0d-08 )
      parameter ( maxcgitnp  =         5 )

C     BETRA constants

      logical extrp4,extrp5
      integer msmaxit
      double precision mseps,msrho,mssig,phieps,trdelini,trdelmin,
     +        tralpha

      parameter ( extrp4     =   .true. )
      parameter ( extrp5     =   .true. )

      parameter ( msmaxit    =       20 )

      parameter ( mseps      =  1.0d-08 )
      parameter ( mssig      =  1.0d-01 )
      parameter ( msrho      =  9.0d-01 )
      parameter ( phieps     =  1.0d-08 )
      parameter ( trdelini   =  1.0d+02 )
      parameter ( trdelmin   =  1.0d-08 )
      parameter ( tralpha    =  1.0d-01 )

C     GENCAN constants

      integer maxinnitnp
      double precision cggpnf,cgepsi,cgepsf,delmin,eta

      parameter ( maxinnitnp =         3 )
      parameter ( delmin     =   1.0d+04 )
      parameter ( eta        =   0.1d0   )
      parameter ( cggpnf     =   1.0d-04 )
      parameter ( cgepsi     =   1.0d-01 )
      parameter ( cgepsf     =   1.0d-08 )

C     ALGENCAN constants

      logical rhorestart
      integer maxoutitnp,maxoutit
      double precision lammax,lammin,rhofrac,rhoinimax,rhoinimin,rhomax,
     +        rhomult

      parameter ( maxoutitnp =        10 )
      parameter ( maxoutit   =       100 )

      parameter ( lammin     = - 1.0d+20 )
      parameter ( lammax     =   1.0d+20 )

      parameter ( rhofrac    =   0.5d0   )
      parameter ( rhomult    =   1.0d+01 )
      parameter ( rhomax     =   1.0d+20 )

      parameter ( rhorestart =    .true. )
      parameter ( rhoinimin  =   1.0d-08 )
      parameter ( rhoinimax  =   1.0d+08 )
C     COMMON SCALARS
      character * 6 hptype
      character * 2 innslvr
      logical ccoded,fccoded,fcoded,gcoded,gjaccoded,innercall,jaccoded,
     +        hcoded,hccoded,hlcoded,hlpcoded,firstde,truehl,ignoref,
     +        skipacc,sclsys,useustp,safemode

C     COMMON BLOCKS
      common /algparam/ fcoded,gcoded,hcoded,ccoded,jaccoded,hccoded,
     +                  hlcoded,hlpcoded,fccoded,gjaccoded,firstde,
     +                  truehl,ignoref,skipacc,sclsys,innercall,useustp,
     +                  innslvr,hptype,safemode
      save   /algparam/
C     COMMON SCALARS
      logical iprintctl(7)
      integer iprintinn,iprintout,mprint,nprint

C     COMMON BLOCKS
      common /outdat/ iprintctl,iprintinn,iprintout,nprint,mprint
      save   /outdat/

C     COMMON SCALARS
      logical scale
      double precision sf,usf

C     COMMON ARRAYS
      double precision sc(mmax),usc(mmax)

C     COMMON BLOCK
      common /scadat/ sc,usc,sf,usf,scale
      save   /scadat/

C     LOCAL SCALARS
      character innstp
      logical scaletmp
      integer cifacnt,geninfo,i,iter,maxit,msqiter,nwinfo,nwiter,
     +        outitnp,xind
      double precision al,csupna,epsfeas12,epsfeas14,epsopt12,epsopt14,
     +        epsopk,fa,nlpi,nlpsupna,rhoa,rhob,rhoc,rhoini,snormb,
     +        snormprev,xsupn

C     LOCAL ARRAYS
      double precision lambar(mmax),lambdaa(mmax),lambdab(mmax),
     +        rho(mmax),xa(nmax),xb(nmax),nc(nmax)

C     DATA BLOCKS
      character genstp(0:9)
      data genstp(0) /'C'/
      data genstp(1) /'M'/
      data genstp(2) /' '/
      data genstp(3) /'P'/
      data genstp(4) /' '/
      data genstp(5) /' '/
      data genstp(6) /'U'/
      data genstp(7) /' '/
      data genstp(8) /' '/
      data genstp(9) /' '/

C     ==================================================================
C     Print initial information
C     ==================================================================

      if ( iprintout .ge. 1 ) then
          write(* ,1000) n,m
          write(10,1000) n,m

          if ( iprintout .ge. 4 .and. nprint .ne. 0 ) then
              write(* ,1010) nprint,(l(i),i=1,nprint)
              write(* ,1020) nprint,(u(i),i=1,nprint)

              write(10,1010) nprint,(l(i),i=1,nprint)
              write(10,1020) nprint,(u(i),i=1,nprint)
          end if

      end if

C     ==================================================================
C     Initialization
C     ==================================================================

C     Counters

      outiter  = 0
      outitnp  = 0

      totiter  = 0

      nwcalls  = 0
      nwtotit  = 0

      msqcalls = 0
      msqtotit = 0

      cifacnt  = 0
      innfail  = .false.

C     Constants

      epsopt12  = sqrt( epsopt    )
      epsopt14  = sqrt( epsopt12  )
      epsfeas12 = sqrt( epsfeas   )
      epsfeas14 = sqrt( epsfeas12 )

C     Project initial point

      do i = 1,n
          x(i) = max( l(i), min( x(i), u(i) ) )
      end do

C     Compute current point norm

      xsupn = 0.0d0
      do i = 1,n
          if ( abs( x(i) ) .ge. xsupn ) then
              xsupn = abs( x(i) )
              xind  = i
          end if
      end do

C     Compute objective function and constraints

      call ssetp(n,x)

      call sevalobjc(n,x,f,fu,m,c,cu,inform)
      if ( inform .lt. 0 ) return

C     Compute safeguarded Lagrange multipliers

      do i = 1,m
          lambar(i) = max( lammin, min( lambda(i), lammax ) )
      end do

C     Compute complementarity and feasibility violations

      snormprev = bignum

      csupn  = 0.0d0
      csupnu = 0.0d0
      snorm  = 0.0d0
      do i = 1,m
          if ( equatn(i) ) then
              csupn  = max( csupn , abs( c(i)  ) )
              csupnu = max( csupnu, abs( cu(i) ) )
              snorm  = max( snorm , abs( c(i)  ) )
          else
              csupn  = max( csupn , c(i)  )
              csupnu = max( csupnu, cu(i) )
              snorm  = max( snorm , abs( min( - c(i), lambda(i) ) ) )
          end if
      end do

C     Compute continuous projected Lagrangian gradient norm

      call sevalnl(n,x,m,lambda,equatn,linear,nl,inform)
      if ( inform .lt. 0 ) return

      nlpsupn = 0.0d0
      do i = 1,n
          nlpi = x(i) - nl(i)
          if ( l(i) .le. nlpi .and. nlpi .le. u(i) ) then
              nlpi = - nl(i)
          else
              nlpi = max( l(i), min( nlpi, u(i) ) ) - x(i)
          end if
          nlpsupn = max( nlpsupn, abs( nlpi ) )
      end do

C     Compute squared-infeasibility gradient norm

      call stafeas(n,x,l,u,m,c,lambda,equatn,nc,ncsupn,inform)
      if ( inform .lt. 0 ) return

C     Save best solution

      fub      = fu
      csupnub  = csupnu

      fb       = f
      csupnb   = csupn
      snormb   = snorm
      nlpsupnb = nlpsupn

      do i = 1,n
          xb(i) = x(i)
      end do

      do i = 1,m
          lambdab(i) = lambda(i)
      end do

C     ==================================================================
C     Main loop
C     ==================================================================

 100  continue

C     ==================================================================
C     Print information of this iteration
C     ==================================================================

      if ( iprintout .eq. 1 ) then

          if ( outiter .eq. 0 ) then
              innstp = ' '
          else
              innstp = genstp(geninfo)
          end if

          if ( .not. scale ) then
              if ( mod(outiter,10) .eq. 0 ) then
                  write(* ,1030)
                  write(10,1030)
              end if

              if ( outiter .eq. 0 ) then
                  write(* ,1041) outiter,      f,csupn,snorm,nlpsupn,
     +                           xsupn,ncsupn,totiter,innstp,nwcalls,
     +                           nwtotit
                  write(10,1041) outiter,      f,csupn,snorm,nlpsupn,
     +                           xsupn,ncsupn,totiter,innstp,nwcalls,
     +                           nwtotit
              else
                  write(* ,1040) outiter,rsupn,f,csupn,snorm,nlpsupn,
     +                           xsupn,ncsupn,totiter,innstp,nwcalls,
     +                           nwtotit
                  write(10,1040) outiter,rsupn,f,csupn,snorm,nlpsupn,
     +                           xsupn,ncsupn,totiter,innstp,nwcalls,
     +                           nwtotit
              end if
          else
              if ( mod(outiter,10) .eq. 0 ) then
                  write(* ,1050)
                  write(10,1050)
              end if

              if ( outiter .eq. 0 ) then
                  write(* ,1061) outiter,      fu,csupnu,f,csupn,snorm,
     +                           nlpsupn,ncsupn,totiter,innstp,nwcalls,
     +                           nwtotit
                  write(10,1061) outiter,      fu,csupnu,f,csupn,snorm,
     +                           nlpsupn,ncsupn,totiter,innstp,nwcalls,
     +                           nwtotit
              else
                  write(* ,1060) outiter,rsupn,fu,csupnu,f,csupn,snorm,
     +                           nlpsupn,ncsupn,totiter,innstp,nwcalls,
     +                           nwtotit
                  write(10,1060) outiter,rsupn,fu,csupnu,f,csupn,snorm,
     +                           nlpsupn,ncsupn,totiter,innstp,nwcalls,
     +                           nwtotit
              end if
          end if

      else if ( iprintout .ge. 2 ) then
          if ( outiter .eq. 0 ) then
              write(* ,1071) outiter
              write(10,1071) outiter
          else
              write(* ,1070) outiter,rsupn
              write(10,1070) outiter,rsupn
          end if

          if ( iprintout .ge. 3 ) then
              write(* ,1080) totiter,nwcalls,nwtotit
              write(10,1080) totiter,nwcalls,nwtotit
          end if

          if ( .not. scale ) then
              write(* ,1090) f,csupn
              write(10,1090) f,csupn
          else
              write(* ,1100) f,fu,csupn,csupnu
              write(10,1100) f,fu,csupn,csupnu
          end if

          write(* ,1110) snorm,nlpsupn,ncsupn,xind,xsupn
          write(10,1110) snorm,nlpsupn,ncsupn,xind,xsupn

          if ( iprintout .ge. 4 ) then
              if ( nprint .ne. 0 ) then
                  write(* ,1120) nprint,(x(i),i=1,nprint)
                  write(10,1120) nprint,(x(i),i=1,nprint)
              end if

              if ( mprint .ne. 0 ) then
                  write(* ,1130) mprint,(lambda(i),i=1,mprint)
                  write(10,1130) mprint,(lambda(i),i=1,mprint)

                  if ( .not. scale ) then
                      write(* ,1150) mprint,(c(i),i=1,mprint)
                      write(10,1150) mprint,(c(i),i=1,mprint)
                  else
                      write(* ,1160) mprint,(cu(i),i=1,mprint)
                      write(10,1160) mprint,(cu(i),i=1,mprint)
                      write(* ,1170) mprint,(c(i),i=1,mprint)
                      write(10,1170) mprint,(c(i),i=1,mprint)
                  end if
              end if
          end if

      end if

C     Save intermediate data for crash report

      if ( iprintctl(6) ) then
          open(20,file='algencan-tabline.out')
          write(20,1400) fu,csupnu,f,csupn,nlpsupn,fub,csupnub,fb,
     +                   csupnb,nlpsupnb,ncsupn,rsupn,inform,9,innfail,
     +                   n,m,outiter,totiter,0,nwcalls,nwtotit,msqcalls,
     +                   msqtotit,999.9d0
          close(20)
      end if

C     ==================================================================
C     Test stopping criteria
C     ==================================================================

C     Test feasibility, optimality and complementarity

      if ( max( snorm, csupnu ) .le. epsfeas .and.
     +     nlpsupn .le. epsopt ) then
          alinfo = 0

          if ( iprintout .ge. 1 ) then
              write(*, 1300)
              write(10,1300)
          end if

          return
      end if

C     Test whether we are at a stationary of the infeasibility 
C     infeasible point

c      if ( csupn .gt. epsfeas .and. ncsupn .le. epsopt ** 1.5d0  ) then

c          alinfo = 1

c          if ( iprintout .ge. 1 ) then
c              write(*, 1310)
c              write(10,1310)
c          end if

c          return
c      end if

C     Test whether the penalty parameter is too large

      if ( outiter .gt. 0 .and. rsupn .gt. rhomax ) then

          alinfo = 2

          if ( iprintout .ge. 1 ) then
              write(*, 1320)
              write(10,1320)
          end if

          return
      end if

C     Test whether the number of iterations is exhausted

      if ( outiter .ge. maxoutit ) then
          alinfo = 3

          if ( iprintout .ge. 1 ) then
              write(*, 1330)
              write(10,1330)
          end if

          return
      end if

C     ==================================================================
C     Near the solution, try to solve the KKT system by Newton's method
C     ==================================================================

      if ( .not. skipacc .and. truehl .and. ( nwcalls .gt. 0 .or.
     +     ( snorm .le. epsfeas12 .and. nlpsupn .le. epsopt12 ) .or.
     +     ( snorm .le. epsfeas14 .and. nlpsupn .le. epsopt14 .and.
     +       outiter .gt. 0 .and. geninfo .ne. 0 ) ) ) then

          nwcalls = nwcalls + 1

          do i = 1,n
              xa(i) = x(i)
          end do

          do i = 1,m
              lambdaa(i) = lambar(i)
          end do

          scaletmp = scale

          if ( scale ) then
              do i = 1,m
                  lambdaa(i) = lambdaa(i) * sc(i) / sf
              end do

              scale = .false.
          end if

          call newtonkkt(n,xa,l,u,m,lambdaa,equatn,linear,epsfeas,
     +    epsopt,fa,csupna,nlpsupna,nwiter,msqiter,nwinfo,inform)

          nwtotit = nwtotit  + nwiter

          if ( nwinfo .ge. 6 ) then
              skipacc = .true.
          end if

          if ( msqiter .gt. 0 ) then
              msqcalls = msqcalls + 1
              msqtotit = msqtotit + msqiter
          end if

          if ( inform .lt. 0 ) return

C         Save best solution

          if ( ( csupnub .gt. epsfeas .and. csupna .le. csupnub ) .or.
     +         ( csupnub .le. epsfeas .and. csupna .le. epsfeas .and.
     +           fa .le. fub ) ) then

              fub      = fa
              csupnub  = csupna

              fb       = fa
              csupnb   = csupna
              snormb   = 0.0d0
              nlpsupnb = nlpsupna

              do i = 1,n
                  xb(i) = xa(i)
              end do

              do i = 1,m
                  lambdab(i) = lambdaa(i)
              end do

          end if

C         Test feasibility, optimality and complementarity

          if ( csupna .le. epsfeas .and. nlpsupna .le. epsopt ) then

              fu      = fa
              csupnu  = csupna

              f       = fa
              csupn   = csupna
              snorm   = 0.0d0
              nlpsupn = nlpsupna

              do i = 1,n
                  x(i) = xa(i)
              end do

              do i = 1,m
                  lambda(i) = lambdaa(i)
              end do

              alinfo = 0

              if ( iprintout .ge. 1 ) then
                  write(*, 1300)
                  write(10,1300)
              end if

              return

          end if

          scale = scaletmp

      end if

C     ==================================================================
C     Iteration
C     ==================================================================

      outiter = outiter + 1

C     ==================================================================
C     Set penalty parameter
C     ==================================================================

C     Set (or update) penalty parameters and compute maximum rho

      if ( outiter .eq. 1 .or. outiter .eq. 2 ) then

          call comprhoini(f,m,c,equatn,rhoini)

          rhoini = max( rhoinimin, min( rhoini, rhoinimax ) )

          do i = 1,m
              rho(i) = rhoini
          end do

          if ( iprintout .ge. 5 ) then
              write(*, 1200)
              write(10,1200)
          end if

          rhoa = rhoinimin
          rhob = rhoinimax
          rhoc = rhoinimin

      else if ( max( snorm, csupnu ) .gt. epsfeas ) then

          if ( snorm .gt. rhofrac * snormprev ) then

              do i = 1,m
                  rho(i) = max( rhomult * rho(i), rhoc )
              end do

              if ( iprintout .ge. 5 ) then
                  write(*, 1220) rhomult
                  write(10,1220) rhomult
              end if

          else

              if ( iprintout .ge. 5 ) then
                  write(*, 1210)
                  write(10,1210)
              end if

          end if

      else if ( rhorestart ) then
 
          if ( cifacnt .ge. 2 ) then

              rhoa = min( rhoa * rhomult, 1.0d0 )
              rhob = max( rhob / rhomult, 1.0d0 )
              rhoc = rhoc * rhomult

              call comprhoini(f,m,c,equatn,rhoini)

              rhoini = max( rhoa, min( rhoini, rhob ) )

              do i = 1,m
                  rho(i) = min( rhoini, rho(i) )
              end do

              if ( iprintout .ge. 5 ) then
                  write(*, 1230)
                  write(10,1230)
              end if

          else

              if ( iprintout .ge. 5 ) then
                  write(*, 1210)
                  write(10,1210)
              end if

          end if

      end if

C     Compute maximum rho

      rsupn = 0.0d0
      do i = 1,m
          rsupn = max( rsupn, rho(i) )
      end do

C     ==================================================================
C     Solve the augmented Lagrangian subproblem
C     ==================================================================

C     Set optimality requeriment for the subproblem

      if ( outiter .eq. 1 ) then
          epsopk = sqrt( epsopt )
      else if ( snorm .le. epsfeas12 .and. nlpsupn .le. epsopt12 ) then
          epsopk = min( rhofrac * nlpsupn, 0.1d0 * epsopk )
          epsopk = max( epsopk, epsopt )
      end if

      if ( outiter .eq. 1 ) then
          maxit =   10
      else
          maxit = 1000
      end if

C     Call the inner-solver

      call gencan(n,x,l,u,m,lambar,equatn,linear,rho,epsfeas,epsopk,
     +maxit,iter,al,nl,nlpsupn,csupn,csupnu,geninfo,inform)

      totiter = totiter + iter

      if ( outiter .eq. 1 ) then
          geninfo = 0
      end if

      if ( geninfo .ne. 0 ) then
          innfail = .true.
      end if

      if ( inform .lt. 0 ) return

C     ==================================================================
C     Prepare for the next iteration
C     ==================================================================

C     Compute current point norm and its difference with the previous one

      xsupn = 0.0d0
      do i = 1,n
          if ( abs( x(i) ) .ge. xsupn ) then
              xsupn = abs( x(i) )
              xind  = i
          end if
      end do

C     Compute objective function and constraints

      call ssetp(n,x)

      call sevalobjc(n,x,f,fu,m,c,cu,inform)
      if ( inform .lt. 0 ) return

C     Compute feasibility violation

      csupn  = 0.0d0
      csupnu = 0.0d0
      do i = 1,m
          if ( equatn(i) ) then
              csupn  = max( csupn , abs( c(i)  ) )
              csupnu = max( csupnu, abs( cu(i) ) )
          else
              csupn  = max( csupn , c(i)  )
              csupnu = max( csupnu, cu(i) )
          end if
      end do

C     Update Lagrange multipliers approximation

      do i = 1,m
          call evaldpdy(c(i),rho(i),lambar(i),equatn(i),lambda(i))
          lambar(i) = max( lammin, min( lambda(i), lammax ) )
      end do

C     Compute complementarity violation

      snormprev = snorm

      snorm = 0.0d0
      do i = 1,m
          if ( equatn(i) ) then
              snorm = max( snorm, abs( c(i) ) )
          else
              snorm = max( snorm, abs( min( - c(i), lambda(i) ) ) )
          end if
      end do

C     Track consecutve failures of the inner solver at feasible points

      if ( max( snorm, csupnu ) .le. epsfeas .and. geninfo .ne. 0 ) then
          cifacnt = cifacnt + 1
      else
          cifacnt = 0
      end if
 
C     Compute continuous projected Lagrangian gradient norm

      call sevalnl(n,x,m,lambda,equatn,linear,nl,inform)
      if ( inform .lt. 0 ) return

      nlpsupn = 0.0d0
      do i = 1,n
          nlpi = x(i) - nl(i)
          if ( l(i) .le. nlpi .and. nlpi .le. u(i) ) then
              nlpi = - nl(i)
          else
              nlpi = max( l(i), min( nlpi, u(i) ) ) - x(i)
          end if
          nlpsupn = max( nlpsupn, abs( nlpi ) )
      end do

C     Compute squared-infeasibility gradient norm

      call stafeas(n,x,l,u,m,c,lambda,equatn,nc,ncsupn,inform)
      if ( inform .lt. 0 ) return

C     Save best solution

      if ( ( csupnub .gt. epsfeas .and. csupnu .le. csupnub ) .or.
     +     ( csupnub .le. epsfeas .and. csupnu .le. epsfeas .and.
     +       f .lt. fb ) ) then

          fub      = fu
          csupnub  = csupnu

          fb       = f
          csupnb   = csupn
          snormb   = snorm
          nlpsupnb = nlpsupn

          do i = 1,n
              xb(i) = x(i)
          end do

          do i = 1,m
              lambdab(i) = lambda(i)
          end do

      end if

C     ==================================================================
C     Iterate
C     ==================================================================

      go to 100

C     ==================================================================
C     End of main loop
C     ==================================================================

C     NON-EXECUTABLE STATEMENTS

 1000 format(/,1X,'Entry to ALGENCAN.',
     +       /,1X,'Number of variables  : ',I7,
     +       /,1X,'Number of constraints: ',I7)
 1010 format(/,1X,'Lower bounds  (first ',I7,' components):',
     +       /,6(1X,1P,D11.4))
 1020 format(/,1X,'Upper bounds  (first ',I7,' components):',
     +       /,6(1X,1P,D11.4))

 1030 format(/,'out',1X,'penalt',2X,'objective',1X,'infeas',1X,'infeas',
     +         1X,'norm',3X,'norm',3X,'|Grad|',2X,'inner',1X,'Newton',
     +       /,'ite',9X,'function',2X,'ibilty',1X,'+compl',1X,'graLag',
     +         1X,'point',2X,'infeas',2X,'totit',1X,'forKKT')

 1040 format(I3,1X,1P,D6.0,1X,1P,D10.3,5(1X,1P,D6.0),1X,I5,A1,1X,I2,1X,
     +       I3)
 1041 format(I3,7X,        1X,1P,D10.3,5(1X,1P,D6.0),1X,I5,A1,1X,I2,1X,
     +       I3)

 1050 format(/,'out',1X,'penalt',2X,'objective',1X,'infeas',2X,'scaled',
     +         4X,'scaled',1X,'infeas',1X,'norm',3X,'|Grad|',1X,'inner',
     +         1X,'Newton',/,'ite',9X,'function',2X,'ibilty',2X,
     +         'obj-funct',1X,'infeas',1X,'+compl',1X,'graLag',1X,
     +         'infeas',1X,'totit',1X,'forKKT')

 1060 format(I3,1X,1P,D6.0,1X,1P,D10.3,1X,1P,D6.0,1X,1P,D10.3,4(1X,1P,
     +       D6.0),I5,A1,1X,I2,1X,I3)
 1061 format(I3,7X,        1X,1P,D10.3,1X,1P,D6.0,1X,1P,D10.3,4(1X,1P,
     +       D6.0),I5,A1,1X,I2,1X,I3)

 1070 format(/,1X,'ALGENCAN OUTER ITERATION                         = ',
     +         I7,
     +       /,1X,'Penalty parameter                                = ',
     +         1P,D7.1)

 1071 format(/,1X,'ALGENCAN OUTER ITERATION                         = ',
     +         I7)

 1080 format(/,1X,'Up-to-now total number of iterations             = ',
     +         I7,
     +       /,1X,'Up-to-now acceleration trials                    = ',
     +         I7,
     +       /,1X,'Up-to-now total number of Newton iterations      = ',
     +         I7)

 1090 format(/,1X,'Functional value                                 = ',
     +             1P,D24.16,
     +       /,1X,'Sup-norm of infeasibility                        = ',
     +             17X,1P,D7.1)

 1100 format(/,1X,'Functional value             (scaled = ',1P,D8.1,
     +            ') = ',1P,D24.16,
     +       /,1X,'Sup-norm of infeasibility    (scaled = ',1P,D8.1,
     +            ') = ',17X,1P,D7.1)

 1110 format(  1X,'Sup-norm of scaled infeasibility-complementarity = ',
     +             17X,1P,D7.1,
     +       /,1X,'Sup-norm of scaled Lagrangian projected gradient = ',
     +             17X,1P,D7.1,
     +       /,1X,'Sup-norm of scaled infeasibilities gradient      = ',
     +             17X,1P,D7.1,
     +       /,1X,'Sup-norm of x (attained at x_{', I7,'})          = ',
     +             17X,1P,D7.1)

 1120 format(/,1X,'Current point (first ',I7,' components):',
     +       /,6(1X,1P,D11.4))
 1130 format(/,1X,'Current Lagrange multipliers (first ',I7,
     +         1X,'components):',
     +       /,6(1X,1P,D11.4))
 1150 format(/,1X,'Infeasibility (first ',I7,' components):',
     +       /,6(1X,1P,D11.4))
 1160 format(/,1X,'Unscaled infeasibility (first ',I7,' components):',
     +       /,6(1X,1P,D11.4))
 1170 format(/,1X,'Scaled infeasibility (first ',I7,' components):',
     +       /,6(1X,1P,D11.4))

 1200 format(/,1X,'Penalty parameter was computed from scratch as it ',
     +            'is usual in the first two',/,1X,'iterations.')
 1210 format(/,1X,'The desired infeasibility improvement was achieved.',
     +       /,1X,'The penalty parameter was not modified.')
 1220 format(/,1X,'The desired infeasibility improvement was not ',
     +            'achieved.',
     +       /,1X,'The penalty parameter was increased by multiplying ',
     +            'it by rhomult = ',1PD11.4,'.')
 1230 format(/,1X,'Penalty parameter was computed from scratch ',
     +            'because its value seems to be preventing ',
     +            'convergence of the inner solver.')

 1300 format(/,1X,'Flag of ALGENCAN: Solution was found.')
 1310 format(/,1X,'Flag of ALGENCAN: It seems that a stationary-of-',
     +            'the-infeasibility probably',/,1X,'infeasible point ',
     +            'was found. Whether the final iterate is a solution ',
     +            'or not',/,1X,'requires further analysis.')
 1320 format(/,1X,'Flag of ALGENCAN: The penalty parameter is too ',
     +            'large.',/,1X,'The problem may be infeasibile or ',
     +            'bad scaled. Further analysis is required.')
 1330 format(/,1X,'Flag of ALGENCAN: Maximum of iterations reached. ',
     +            'The feasibility-',/,1X,'complementarity and ',
     +            'optimality tolerances could not be achieved. ',
     +            'Whether the',/,1X,'final iterate is a solution or ',
     +            'not requires further analysis.')

 1400 format(1X,1P,D24.16,1X,1P,D7.1,1X,1P,D24.16,1X,1P,D7.1,1X,1P,D7.1,
     +       1X,1P,D24.16,1X,1P,D7.1,1X,1P,D24.16,1X,1P,D7.1,1X,1P,D7.1,
     +       1X,1P,D7.1,1X,1P,D7.1,1X,I3,1X,I1,1X,L1,1X,I6,1X,I6,1X,I3,
     +       1X,I7,1X,I7,1X,I2,1X,I7,1X,I7,1X,I7,0P,F8.2)

      end

C     ******************************************************************
C     ******************************************************************

      subroutine comprhoini(f,m,c,equatn,rhoini)

C     SCALAR ARGUMENTS
      integer m
      double precision f,rhoini

C     ARRAY ARGUMENTS
      logical equatn(m)
      double precision c(m)

C     Consider the Augmented Lagrangian function
C
C         al = f(x) + \sum_i P(lambda_i,c_i(x),rho),
C
C     where
C
C         P(lambda,y,rho) = y ( lambda + 0.5 rho y ),
C
C     If c_i(x) is an equality constraint or lambda + rho y > 0, and
C
C         P(lambda,y,rho) = - 0.5 lambda^2 / rho,
C
C     otherwise.
C
C     Assuming that lambda_i = 0 for all i, it is clear that
C
C         P(lambda_i,c_i(x),rho) = 0.5 rho c_i(x)^2
C
C     and that the value of  rho that balances f(x) and
C
C     \sum_i P(lambda_i,c_i(x),rho) is given by
C
C     rho = f(x) / ( 0.5 \sum_i c_i(x)^2 ).

C     COMMON SCALARS
      double precision bignum,macheps,macheps12,macheps13,macheps23

C     COMMON BLOCKS
      common /machcon/ bignum,macheps,macheps12,macheps13,macheps23
      save   /machcon/

C     LOCAL SCALARS
      integer i
      double precision sumc

      sumc = 0.0d0
      do i = 1,m
          if ( equatn(i) .or. c(i) .gt. 0.0d0 ) then
              sumc = sumc + 0.5d0 * c(i) ** 2
          end if
      end do

      rhoini = 10.0d0 * max( 1.0d0, abs( f ) ) / max( 1.0d0, sumc )

      end

C     ******************************************************************
C     ******************************************************************

      subroutine sevalfeas(n,x,m,equatn,csupn,csupnu,inform)

      implicit none

C     SCALAR ARGUMENTS
      double precision csupn,csupnu
      integer inform,m,n

C     ARRAY ARGUMENTS
      logical equatn(m)
      double precision x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical constrc,gotc

C     COMMON ARRAYS
      integer jcvar(jcnnzmax),jcsta(mmax),jclen(mmax)
      double precision c(mmax),dpdc(mmax),g(nmax),gparc(nmax),
     +        jcval(jcnnzmax)

C     COMMON BLOCKS
      common /gdata/ g,gparc,c,dpdc,jcval,jcvar,jcsta,jclen,constrc,gotc
      save   /gdata/
C     COMMON SCALARS
      logical scale
      double precision sf,usf

C     COMMON ARRAYS
      double precision sc(mmax),usc(mmax)

C     COMMON BLOCK
      common /scadat/ sc,usc,sf,usf,scale
      save   /scadat/

C     LOCAL SCALARS
      integer i

C     Subroutine sevalnal is always called by GENCAN with the same point
C     before calling this subroutine. Then, constraints are computed and
C     saved.

C     Compute infeasibility

      csupn = 0.0d0
      do i = 1,m
          if ( equatn(i) ) then
              csupn = max( csupn, abs( c(i) ) )
          else
              csupn = max( csupn, c(i) )
          end if
      end do

      if ( scale ) then
          csupnu = 0.0d0
          do i = 1,m
              if ( equatn(i) ) then
                  csupnu = max( csupnu, abs( c(i) / sc(i) ) )
              else
                  csupnu = max( csupnu, c(i) / sc(i) )
              end if
          end do

      else
          csupnu = csupn
      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine stafeas(n,x,l,u,m,r,lambda,equatn,nc,ncsupn,inform)

      implicit none

C     SCALAR ARGUMENTS
      double precision ncsupn
      integer inform,m,n

C     ARRAY ARGUMENTS
      logical equatn(m)
      double precision l(n),lambda(m),nc(n),r(m),u(n),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      character * 6 hptype
      character * 2 innslvr
      logical ccoded,fccoded,fcoded,gcoded,gjaccoded,innercall,jaccoded,
     +        hcoded,hccoded,hlcoded,hlpcoded,firstde,truehl,ignoref,
     +        skipacc,sclsys,useustp,safemode

C     COMMON BLOCKS
      common /algparam/ fcoded,gcoded,hcoded,ccoded,jaccoded,hccoded,
     +                  hlcoded,hlpcoded,fccoded,gjaccoded,firstde,
     +                  truehl,ignoref,skipacc,sclsys,innercall,useustp,
     +                  innslvr,hptype,safemode
      save   /algparam/
C     COMMON SCALARS
      logical constrc,gotc

C     COMMON ARRAYS
      integer jcvar(jcnnzmax),jcsta(mmax),jclen(mmax)
      double precision c(mmax),dpdc(mmax),g(nmax),gparc(nmax),
     +        jcval(jcnnzmax)

C     COMMON BLOCKS
      common /gdata/ g,gparc,c,dpdc,jcval,jcvar,jcsta,jclen,constrc,gotc
      save   /gdata/

C     LOCAL SCALARS
      integer i,j,nrnnz
      double precision nci

C     LOCAL ARRAYS
      integer nrvar(nmax)
      double precision nrval(nmax)

      do i = 1,n
          nc(i) = 0.0d0
      end do

      do j = 1,m
          if ( equatn(j) .or. r(j) .gt. 0.0d0 ) then

              if ( gjaccoded ) then
                  do i = jcsta(j),jcsta(j) + jclen(j) - 1
                      nc(jcvar(i)) = nc(jcvar(i)) + r(j) * jcval(i)
                  end do

              else ! if ( gcoded .and. jaccoded ) then

                  if ( equatn(j) .or. lambda(j) .gt. 0.0d0 ) then
                      do i = jcsta(j),jcsta(j) + jclen(j) - 1
                          nc(jcvar(i)) = nc(jcvar(i)) + r(j) * jcval(i)
                      end do

                  else
                      call sevaljac(n,x,j,nrvar,nrval,nrnnz,inform)
                      do i = 1,nrnnz
                          nc(nrvar(i)) = nc(nrvar(i)) + r(j) * nrval(i)
                      end do

                  end if

              end if

          end if
      end do

      ncsupn = 0.0d0
      do i = 1,n
          nci = x(i) - nc(i)
          if ( l(i) .le. nci .and. nci .le. u(i) ) then
              nci = - nc(i)
          else
              nci = max( l(i), min( nci, u(i) ) ) - x(i)
          end if

          ncsupn = max( ncsupn, abs( nci ) )
      end do

      end
C     ******************************************************************
C     ******************************************************************

      subroutine gencan(n,x,l,u,m,lambda,equatn,linear,rho,epsfeas,
     +epsopt,maxit,iter,f,g,gpsupn,cnorm,cnormu,geninfo,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer geninfo,inform,iter,m,maxit,n
      double precision cnorm,cnormu,epsfeas,epsopt,f,gpsupn

C     ARRAY ARGUMENTS
      logical equatn(m),linear(m)
      double precision g(n),l(n),lambda(m),rho(m),u(n),x(n)

C     Solves the box-constrained minimization problem
C
C            Minimize f(x) subject to l <= x <= u
C
C     using the method described in
C
C     E. G. Birgin and J. M. Martinez, ''Large-scale active-set box-
C     constrained optimization method with spectral projected
C     gradients'', Computational Optimization and Applications 23, pp.
C     101-125, 2002.

C     geninfo:
C
C     0: Small continuous-projected-gradient norm
C     1: Maximum number of gencan iterations reached
C     3: Lack of progress
C     6: Unbounded objective function?

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      double precision bignum,macheps,macheps12,macheps13,macheps23

C     COMMON BLOCKS
      common /machcon/ bignum,macheps,macheps12,macheps13,macheps23
      save   /machcon/
C     PARAMETERS

C     General constants

      double precision fmin

      parameter ( fmin       = - 1.0d+20 )

C     Line search constants

      integer maxextrap,mininterp
      double precision beta,etaint,etaext,gamma,sigma1,sigma2

      parameter ( maxextrap  =       100 )
      parameter ( mininterp  =         4 )

      parameter ( gamma      =   1.0d-04 )
      parameter ( beta       =     0.5d0 )
      parameter ( sigma1     =     0.1d0 )
      parameter ( sigma2     =     0.9d0 )
      parameter ( etaint     =     2.0d0 )
      parameter ( etaext     =     2.0d0 )

C     Safeguarding spectral step constants

      double precision lspgma,lspgmi

      parameter ( lspgma     =   1.0d+10 )
      parameter ( lspgmi     =   1.0d-10 )

C     Conjugate gradients constants

      integer maxcgitnp
      double precision epsnqmp,theta

      parameter ( theta      =   1.0d-06 )
      parameter ( epsnqmp    =   1.0d-08 )
      parameter ( maxcgitnp  =         5 )

C     BETRA constants

      logical extrp4,extrp5
      integer msmaxit
      double precision mseps,msrho,mssig,phieps,trdelini,trdelmin,
     +        tralpha

      parameter ( extrp4     =   .true. )
      parameter ( extrp5     =   .true. )

      parameter ( msmaxit    =       20 )

      parameter ( mseps      =  1.0d-08 )
      parameter ( mssig      =  1.0d-01 )
      parameter ( msrho      =  9.0d-01 )
      parameter ( phieps     =  1.0d-08 )
      parameter ( trdelini   =  1.0d+02 )
      parameter ( trdelmin   =  1.0d-08 )
      parameter ( tralpha    =  1.0d-01 )

C     GENCAN constants

      integer maxinnitnp
      double precision cggpnf,cgepsi,cgepsf,delmin,eta

      parameter ( maxinnitnp =         3 )
      parameter ( delmin     =   1.0d+04 )
      parameter ( eta        =   0.1d0   )
      parameter ( cggpnf     =   1.0d-04 )
      parameter ( cgepsi     =   1.0d-01 )
      parameter ( cgepsf     =   1.0d-08 )

C     ALGENCAN constants

      logical rhorestart
      integer maxoutitnp,maxoutit
      double precision lammax,lammin,rhofrac,rhoinimax,rhoinimin,rhomax,
     +        rhomult

      parameter ( maxoutitnp =        10 )
      parameter ( maxoutit   =       100 )

      parameter ( lammin     = - 1.0d+20 )
      parameter ( lammax     =   1.0d+20 )

      parameter ( rhofrac    =   0.5d0   )
      parameter ( rhomult    =   1.0d+01 )
      parameter ( rhomax     =   1.0d+20 )

      parameter ( rhorestart =    .true. )
      parameter ( rhoinimin  =   1.0d-08 )
      parameter ( rhoinimax  =   1.0d+08 )
C     COMMON SCALARS
      character * 6 hptype
      character * 2 innslvr
      logical ccoded,fccoded,fcoded,gcoded,gjaccoded,innercall,jaccoded,
     +        hcoded,hccoded,hlcoded,hlpcoded,firstde,truehl,ignoref,
     +        skipacc,sclsys,useustp,safemode

C     COMMON BLOCKS
      common /algparam/ fcoded,gcoded,hcoded,ccoded,jaccoded,hccoded,
     +                  hlcoded,hlpcoded,fccoded,gjaccoded,firstde,
     +                  truehl,ignoref,skipacc,sclsys,innercall,useustp,
     +                  innslvr,hptype,safemode
      save   /algparam/
C     COMMON SCALARS
      integer nbds

C     COMMON BLOCKS
      common /probdata/ nbds
      save   /probdata/

C     COMMON SCALARS
      integer efcnt,efccnt,egcnt,egjccnt,ehcnt,ehlcnt,ehlpcnt,fcnt

C     COMMON ARRAYS
      integer eccnt(mmax),ehccnt(mmax),ejccnt(mmax)

C     COMMON BLOCKS
      common /counters/ eccnt,ehccnt,ejccnt,efcnt,efccnt,egcnt,egjccnt,
     +                  ehcnt,ehlcnt,ehlpcnt,fcnt
      save   /counters/
C     COMMON SCALARS
      logical iprintctl(7)
      integer iprintinn,iprintout,mprint,nprint

C     COMMON BLOCKS
      common /outdat/ iprintctl,iprintinn,iprintout,nprint,mprint
      save   /outdat/

C     COMMON SCALARS
      integer nt

C     COMMON ARRAYS
      integer ind(nmax)
      double precision xcomplement(nmax)

C     COMMON BLOCKS
      common /rspace/ xcomplement,ind,nt
      save   /rspace/
C     COMMON SCALARS
      logical sameface
      integer ittype

C     COMMON BLOCKS
      common /itedat/ sameface,ittype
      save   /itedat/
C     COMMON SCALARS
      double precision seucn,sts,sty,yeucn

C     COMMON ARRAYS
      double precision s(nmax),y(nmax)

C     COMMON BLOCKS
      common /sydata/ s,y,seucn,yeucn,sts,sty
      save   /sydata/

C     LOCAL SCALARS
      character * 6 precond
      character * 2 inniter
      logical forceoi,memfail,vustop
      integer cgcnt,cginfo,cgiter,cgmaxit,chcnt,i,innit,itnfp,itngp,
     +        itnxp,lsinfo,nind,nindprev,nwcnt,lvfit,rbdnnz,trcnt,
     +        trinfo,xind
      double precision acgeps,adsupn,amax,bcgeps,cgeps,cgdel,dsupn,
     +        fbest,fplus,gpeucnb,gieucn,gisupn,gpeucn,gpi,gpsupnb,
     +        lamspg,mslamb,newtrdel,ssupn,tmp,trdel,tsmall,ysupn,xeucn,
     +        xsupn,maxelem

C     LOCAL ARRAYS
      integer rbdind(nmax)
      character rbdtype(nmax)
      double precision d(nmax),dum(nmax),gplus(nmax),xplus(nmax)

C     DATA BLOCKS
      character * 21 ittext(0:4)
      integer BDSREACHED,FSTORDPNT,SECORDPNT,SMALLSTEP,TCLSBNDRY,
     +        TOOSMLTRR,UNBOUNDED,UNDEFSTEP

      data ittext(0) /'(Initial point)     '/
      data ittext(1) /'(SPG step)          '/
      data ittext(2) /'(Truncated Newton)  '/
      data ittext(3) /'(Newton w/MS-system)'/
      data ittext(4) /'(Trust region)      '/

      data BDSREACHED /2/
      data UNBOUNDED  /2/
      data SMALLSTEP  /3/
      data TOOSMLTRR  /4/
      data UNDEFSTEP  /5/
      data FSTORDPNT  /6/
      data SECORDPNT  /7/
      data TCLSBNDRY  /8/

C     EXTERNAL
      logical sstop

C     EXTERNAL SUBROUTINES
      external sevalal,ssetp

C     ==================================================================
C     Initialization
C     ==================================================================

C     Set some initial values:

C     best functional and gradient-norm values
      fbest   = bignum
      gpsupnb = bignum
      gpeucnb = bignum

C     to record a memory failure in the direct solver
      memfail = .false.

C     for Conjugate Gradients
      precond = 'QNCGNA'

C     for the first inner-to-the-face minimization algorithm
      inniter = 'TN'

C     for testing lack of progress checking f, g and x
      itnfp = 0
      itngp = 0
      itnxp = 0

C     to force a leaving-face iteration when lack of progress is
C     detected within a face
      forceoi = .false.

C     for calculating More-Sorensen's direction
      mslamb =  0.0d0

C     for counting number of iterations as well as inner-to-the-face
C     and leaving-face iterations
      iter  = 0
      cgcnt = 0
      nwcnt = 0
      trcnt = 0
      chcnt = 0
      lvfit = 0
      innit = 0

C     just to print "Initial point" in the first ouput
      ittype = 0

C     Print problem information

      if ( iprintinn .ge. 1 ) then
          write(* ,1000) n,epsopt
          write(10,1000) n,epsopt
      end if

      if ( iprintinn .ge. 4 .and. nprint .ne. 0 ) then
          write(* ,1010) nprint,(l(i),i=1,nprint)
          write(* ,1020) nprint,(u(i),i=1,nprint)
          write(* ,1030) nprint,(x(i),i=1,nprint)

          write(10,1010) nprint,(l(i),i=1,nprint)
          write(10,1020) nprint,(u(i),i=1,nprint)
          write(10,1030) nprint,(x(i),i=1,nprint)
      end if

C     Project initial guess. If the initial guess is infeasible,
C     projection puts it into the box.

      do i = 1,n
          x(i) = max( l(i), min( x(i), u(i) ) )
      end do

C     Compute function and gradient at the initial point

      call ssetp(n,x)

      call sevalal(n,x,m,lambda,rho,equatn,linear,f,inform)
      if ( inform .lt. 0 ) return

      call sevalnal(n,x,m,lambda,rho,equatn,linear,g,inform)
      if ( inform .lt. 0 ) return

C     For feasibility problems, compute scaled and unscaled feasibilities

      if ( ignoref ) then
          call sevalfeas(n,x,m,equatn,cnorm,cnormu,inform)
          if ( inform .lt. 0 ) return

      else
          cnorm  = 0.0d0
          cnormu = 0.0d0
      end if

C     Compute x Euclidian and sup norms, continuous-project-gradient
C     Euclidian and sup norms, internal gradient Euclidian norm. Set
C     nind as the number of free variables and save in array ind their
C     identifiers. Also set variable sameface (same face) indicating
C     that the "previous iterate" does not belong to the current face.

      sameface = .false.

      nind   = 0
      xsupn  = 0.0d0
      xeucn  = 0.0d0
      gpsupn = 0.0d0
      gpeucn = 0.0d0
      gisupn = 0.0d0
      gieucn = 0.0d0
      do i = 1,n
          if ( abs( x(i) ) .ge. xsupn ) then
              xsupn = abs( x(i) )
              xind = i
          end if
          xeucn = xeucn + x(i) ** 2
          gpi = x(i) - g(i)
          if ( l(i) .le. gpi .and. gpi .le. u(i) ) then
              gpi = - g(i)
          else
              gpi = max( l(i), min( gpi, u(i) ) ) - x(i)
          end if
          gpsupn = max( gpsupn, abs( gpi ) )
          gpeucn = gpeucn + gpi ** 2
          if ( x(i) .gt. l(i) + macheps23 * max(1.0d0,abs(l(i))) .and.
     +         x(i) .lt. u(i) - macheps23 * max(1.0d0,abs(u(i))) ) then
              gisupn    = max( gisupn, abs( gpi ) )
              gieucn    = gieucn + gpi ** 2
              nind      = nind + 1
              ind(nind) = i
          end if
      end do
      xeucn  = sqrt( xeucn  )
      gpeucn = sqrt( gpeucn )
      gieucn = sqrt( gieucn )

C     Compute trut-region radius, in case betra is used as inner solver

      trdel    = max( trdelmin, trdelini * max( 1.0d0, xeucn ) )
      newtrdel = 0.0d0

C     Initial spectral steplength

C     Compute a small step and set the point at which the auxiliary
C     gradient will be computed

      if ( gpsupn .ne. 0.0d0 ) then
          tsmall = macheps12 * max( 1.0d0, xsupn / gpsupn )
      else
          tsmall = 0.0d0
      end if

      do i = 1,n
          gpi = x(i) - g(i)
          if ( l(i) .le. gpi .and. gpi .le. u(i) ) then
              gpi = - g(i)
          else
              gpi = max( l(i), min( gpi, u(i) ) ) - x(i)
          end if
          s(i) = x(i) + tsmall * gpi
      end do

C     Compute the gradient at the auxiliary point

      call ssetp(n,s)

      call ievalnal(n,s,m,lambda,rho,equatn,linear,y,dum,inform)
      if ( inform .lt. 0 ) return

      call ssetp(n,x)

C     Compute s = x_{1/2} - x_0 and y = g_{1/2} - g_0

      sts = 0.0d0
      sty = 0.0d0
      ssupn = 0.0d0
      ysupn = 0.0d0
      yeucn = 0.0d0
      do i = 1,n
          s(i) = s(i) - x(i)
          y(i) = y(i) - g(i)
          sts  = sts + s(i) ** 2
          sty  = sty + s(i) * y(i)
          ssupn = max( ssupn, abs( s(i) ) )
          ysupn = max( ysupn, abs( y(i) ) )
          yeucn = yeucn + y(i) ** 2
      end do
      seucn = sqrt( sts )
      yeucn = sqrt( yeucn )

C     Compute a linear relation between gpsupn and cgeps, i.e.,
C     scalars a and b such that
c
C         a * log10( ||g_P(x_ini)|| ) + b = log10(cgeps_ini) and
c
C         a * log10( ||g_P(x_fin)|| ) + b = log10(cgeps_fin),
c
C     where cgeps_ini and cgeps_fin are provided. Note that if
C     cgeps_ini is equal to cgeps_fin then cgeps will be always
C     equal to cgeps_ini and cgeps_fin.

      acgeps = log10( cgepsf / cgepsi ) / log10( cggpnf / gpsupn )
      bcgeps = log10( cgepsi ) - acgeps * log10( gpsupn )

C     Print initial information

      if ( iprintinn .eq. 1 ) then
          if ( mod(iter,10) .eq. 0 ) then
              write(* ,1040)
              write(10,1040)
          end if
          write(* ,1050) iter,f,gpsupn,xsupn
          write(10,1050) iter,f,gpsupn,xsupn

      else if ( iprintinn .ge. 2 ) then
          write(* ,1070) iter,ittext(ittype)
          write(10,1070) iter,ittext(ittype)

          if ( iprintinn .ge. 3 ) then
              write(* ,1080) lvfit,innit,fcnt,cgcnt,nwcnt,trcnt,chcnt
              write(10,1080) lvfit,innit,fcnt,cgcnt,nwcnt,trcnt,chcnt
          end if

          write(* ,1090) f,gpsupn,gpeucn,gisupn,gieucn,xind,xsupn,xeucn,
     +                   ssupn,seucn
          write(10,1090) f,gpsupn,gpeucn,gisupn,gieucn,xind,xsupn,xeucn,
     +                   ssupn,seucn

          if ( iprintinn .ge. 4 .and. nprint .ne. 0 ) then
              write(* ,1100) min(nprint,nind),nind,
     +                       (ind(i),i=1,min(nprint,nind))
              write(* ,1110) nprint,(x(i),i=1,nprint)
              write(* ,1130) nprint,(g(i),i=1,nprint)
              write(* ,1140) nprint,(min(u(i),max(l(i),x(i)-g(i)))-x(i),
     +                       i=1,nprint)
              write(10,1100) min(nprint,nind),nind,
     +                       (ind(i),i=1,min(nprint,nind))
              write(10,1110) nprint,(x(i),i=1,nprint)
              write(10,1130) nprint,(g(i),i=1,nprint)
              write(10,1140) nprint,(min(u(i),max(l(i),x(i)-g(i)))-x(i),
     +                       i=1,nprint)
          end if
      end if

C     Save intermediate data for crash report

      if ( iprintctl(6) ) then
          open(20,file='gencan-tabline.out')
          write(20,1400) f,0.0d0,f,0.0d0,gpsupn,f,0.0d0,f,0.0d0,gpsupn,
     +                   0.0d0,0.0d0,inform,9,.false.,n,m,0,iter,fcnt,0,
     +                   0,0,0,999.9d0
          close(20)
      end if

C     ==================================================================
C     Main loop
C     ==================================================================

 100  continue

C     ==================================================================
C     Test stopping criteria
C     ==================================================================

C     Test user-provided stopping criterion

      if ( useustp ) then

          vustop = sstop(n,x,m,lambda,rho,equatn,linear,inform)
          if ( inform .lt. 0 ) return

          if ( vustop ) then
              geninfo = 8

              if ( iprintinn .ge. 1 ) then
                  write(*, 1280)
                  write(10,1280)
              end if

              return
          end if

      end if

C     Test whether the continuous-projected-gradient sup-norm
C     is small enough to declare convergence. In the case of
C     feasibility problems, check feasibility.

      if ( ( .not. ignoref .and. gpsupn .le. epsopt  ) .or.
     +     (       ignoref .and. cnormu .le. epsfeas ) ) then
          geninfo = 0

          if ( iprintinn .ge. 1 ) then
              write(*, 1200)
              write(10,1200)
          end if

          return
      end if

C     Test whether the number of iterations is exhausted

      if ( iter .ge. maxit ) then
          geninfo = 1

          if ( iprintinn .ge. 1 ) then
              write(*, 1210)
              write(10,1210)
          end if

          return
      end if

C     ==================================================================
C     Test stopping criteria related to lack of progress
C     ==================================================================

      if ( iter .gt. 0 ) then

C     Test whether we have performed many iterations without
C     moving from the current point, by checking the functional value

      if ( f .ge. fbest - macheps23 * abs( fbest ) )  then
          itnfp = itnfp + 1
      else
          itnfp = 0
      end if

C     Test whether we have performed many iterations without
C     moving from the current point, by checking their gradients

      if ( gpsupn .ge. gpsupnb - macheps23 * gpsupnb .or. 
     +     gpeucn .ge. gpeucnb - macheps23 * gpeucnb ) then
          itngp = itngp + 1
      else
          itngp = 0
      end if

C     Test whether we have performed many iterations without
C     moving from the current point, by checking the step norm

      if ( ssupn .le. max( macheps23, macheps * xsupn ) .or. 
     +     seucn .le. max( macheps23, macheps * xeucn ) ) then
          itnxp = itnxp + 1
      else
          itnxp = 0
      end if

C     If there was no progress in the objective functional value, its 
C     gradient and the current point, stop

      if ( itnfp .ge. maxinnitnp .and. itngp .ge. maxinnitnp .and.
     +     itnxp .ge. maxinnitnp ) then
          geninfo = 3

          if ( iprintinn .ge. 1 ) then
              write(*, 1230)
              write(10,1230)
          end if

          return
      end if

      end if

C     ==================================================================
C     Iteration
C     ==================================================================

      iter = iter + 1

C     ==================================================================
C     Compute new iterate
C     ==================================================================

C     We abandon the current face if the norm of the internal gradient
C     (here, internal components of the continuous projected gradient)
C     is smaller than eta times the norm of the continuous
C     projected gradient. Using eta = 0.1 is a rather conservative
C     strategy in the sense that internal iterations are preferred over
C     SPG iterations. Replace eta = 0.1 by other tolerance in (0,1) if
C     you find it convenient.

      if ( gieucn .le. eta * gpeucn .or.
     +     gisupn .le. eta * gpsupn .or. forceoi ) then

C         ==============================================================
C         Some constraints should be abandoned. Compute the new iterate
C         using an SPG iteration
C         ==============================================================

          forceoi = .false.
          lvfit = lvfit + 1

C         Compute spectral steplength

          if ( sty .le. 0.0d0 ) then
              lamspg = max( 1.0d0, xsupn / gpsupn )
          else
              lamspg = sts / sty
          end if
          lamspg = min( lspgma, max( lspgmi, lamspg ) )

C         Perform safeguarded quadratic interpolation along the
C         spectral continuous projected gradient

          call spgls(n,x,l,u,m,lambda,rho,equatn,linear,f,g,lamspg,
     +    xplus,fplus,tmp,d,sevalal,ssetp,lsinfo,inform)
          if ( inform .lt. 0 ) return

          call sevalnal(n,xplus,m,lambda,rho,equatn,linear,gplus,inform)
          if ( inform .lt. 0 ) return

C         Set iteration type

          ittype = 1

      else

C         ==============================================================
C         The new iterate will belong to the closure of the current face
C         ==============================================================

          innit = innit + 1

C         Shrink the point, its gradient and the bounds

          call shrink(nind,x)
          call shrink(nind,g)
          call shrink(nind,l)
          call shrink(nind,u)

C         Save values of fixed variables for further evaluations

          do i = 1,n - nind
              xcomplement(i) = x(nind + i)
          end do

          nt = n

C         Compute the new point using a trust-region approach

          if ( inniter .eq. 'TR' ) then

              call betra(n,nind,x,l,u,m,lambda,rho,equatn,linear,f,g,
     +        trdel,newtrdel,mslamb,epsopt,xeucn,xsupn,gpsupn,d,rbdind,
     +        rbdtype,xplus,fplus,gplus,trcnt,chcnt,memfail,trinfo,
     +        inform)

              if ( inform .lt. 0 ) return

C             Set iteration type

              ittype = 4

          end if

C         Compute the descent direction solving the newtonian system

          if ( inniter .eq. 'NW' ) then

C             Solve the Newtonian system
C
C                 ( H + rho A^T A ) x = b
C
C             by solving the Martinez-Santos system
C
C                 H x + A^t y = b
C                 A x - y/rho = 0
C
C             with a direct solver.

              call newtd(nind,x,l,u,g,m,rho,equatn,d,adsupn,maxelem,
     +        memfail,inform)
              if ( inform .lt. 0 ) return

              nwcnt = nwcnt + 1

C             Compute maximum step

              call compamax(nind,x,l,u,d,amax,rbdnnz,rbdind,rbdtype)

C             Perform line search

              call tnls(nind,x,l,u,m,lambda,rho,equatn,linear,f,g,amax,
     +        d,rbdnnz,rbdind,rbdtype,xplus,fplus,gplus,lsinfo,inform)
              if ( inform .lt. 0 ) return

C             Set iteration type

              ittype = 3

          end if

          if (   inniter .eq. 'TN' .or.
     +         ( inniter .eq. 'NW' .and. memfail ) .or.
     +         ( inniter .eq. 'TR' .and. memfail ) .or.
     +         ( inniter .eq. 'TR' .and. trinfo .eq. UNDEFSTEP ) .or.
     +         ( inniter .eq. 'TR' .and. trinfo .eq. TOOSMLTRR ) .or. 
     +         ( inniter .eq. 'TR' .and. trinfo .eq. FSTORDPNT ) .or. 
     +         ( inniter .eq. 'TR' .and. trinfo .eq. SECORDPNT ) .or.
     +         ( inniter .eq. 'TR' .and. trinfo .eq. TCLSBNDRY ) ) then

C             Compute "trust-region radius" for CG

              if ( iter .eq. 1 ) then
                  cgdel = max( 100.0d0, 100.0d0 * xsupn )
              else
                  cgdel = max( delmin, 10.0d0 * ssupn )
              end if

C             Set conjugate gradient stopping criteria.

              cgmaxit = min( nind, 10000 )
              cgeps   = 10.0d0 ** ( acgeps * log10( gpsupn ) + bcgeps )
              cgeps   = max( cgepsf, min( cgepsi, cgeps ) )

C             Call Conjugate Gradients to solve the Newtonian system

              call cgm(nind,x,m,lambda,rho,equatn,linear,l,u,g,cgdel,
     +        cgeps,cgmaxit,precond,d,rbdnnz,rbdind,rbdtype,cgiter,
     +        cginfo,inform)

              cgcnt = cgcnt + cgiter

              if ( inform .lt. 0 ) return

C             Compute maximum step

              if ( cginfo .eq. BDSREACHED ) then
                  amax = 1.0d0
              else
                  call compamax(nind,x,l,u,d,amax,rbdnnz,rbdind,rbdtype)
              end if

C             Perform line search

              call tnls(nind,x,l,u,m,lambda,rho,equatn,linear,f,g,amax,
     +        d,rbdnnz,rbdind,rbdtype,xplus,fplus,gplus,lsinfo,inform)
              if ( inform .lt. 0 ) return

C             Set iteration type

              ittype = 2

          end if

C         Set iteration type for the next iteration

          dsupn = 0.0d0
          do i = 1,nind
              dsupn = max( dsupn, abs( d(i) ) )
          end do

          if (   memfail .or. 
     +         ( ittype .eq. 3 .and. adsupn .gt. maxelem ) .or.
     +         ( ittype .eq. 3 .and. amax .le. macheps12 * dsupn ) )
     +    then
              inniter = 'TN'
          else
              inniter = innslvr
          end if

C         Test whether to force a leaving-face iteration is recommended

          if ( nbds .gt. 0 .and.
     +         ( ittype .eq. 2 .and. lsinfo .eq. SMALLSTEP ) .or.
     +         ( ittype .eq. 4 .and. trinfo .eq. SMALLSTEP ) ) then
              forceoi = .true.
          end if

C         Expand the point, its gradient and the bounds. Also expand
C         xplus and gplus.

          call expand(nind,x)
          call expand(nind,g)
          call expand(nind,l)
          call expand(nind,u)

          call expand(nind,xplus)
          call expand(nind,gplus)
      end if

C     For feasibility problems, compute scaled and unscaled feasibilities

      if ( ignoref ) then
          call sevalfeas(n,x,m,equatn,cnorm,cnormu,inform)
          if ( inform .lt. 0 ) return

      else
          cnorm  = 0.0d0
          cnormu = 0.0d0
      end if

C     Compute s = xplus - x and y = gplus - g

      if ( f      .lt. fbest   ) fbest   = f
      if ( gpsupn .lt. gpsupnb ) gpsupnb = gpsupn
      if ( gpeucn .lt. gpeucnb ) gpeucnb = gpeucn

      sts = 0.0d0
      sty = 0.0d0
      ssupn = 0.0d0
      ysupn = 0.0d0
      yeucn = 0.0d0
      do i = 1,n
          s(i) = xplus(i) - x(i)
          y(i) = gplus(i) - g(i)
          sts  = sts + s(i) ** 2
          sty  = sty + s(i) * y(i)
          ssupn = max( ssupn, abs( s(i) ) )
          ysupn = max( ysupn, abs( y(i) ) )
          yeucn = yeucn + y(i) ** 2
      end do
      seucn = sqrt( sts )
      yeucn = sqrt( yeucn )

C     Set new point

      f = fplus

      do i = 1,n
          x(i) = xplus(i)
          g(i) = gplus(i)
      end do

C     ==================================================================
C     Prepare for the next iteration
C     ==================================================================

C     Compute continuous-project-gradient Euclidian and Sup norms,
C     internal gradient Euclidian norm, and store in nind the number of
C     free variables and in array ind their identifiers. Verify whether
C     x and xprev belong to the same face.

      sameface = .true.
      nindprev = nind

      nind   = 0
      xsupn  = 0.0d0
      xeucn  = 0.0d0
      gpsupn = 0.0d0
      gpeucn = 0.0d0
      gisupn = 0.0d0
      gieucn = 0.0d0
      do i = 1,n
          if ( abs( x(i) ) .ge. xsupn ) then
              xsupn = abs( x(i) )
              xind = i
          end if
          xeucn = xeucn + x(i) ** 2
          gpi = x(i) - g(i)
          if ( l(i) .le. gpi .and. gpi .le. u(i) ) then
              gpi = - g(i)
          else
              gpi = max( l(i), min( gpi, u(i) ) ) - x(i)
          end if
          gpsupn = max( gpsupn, abs( gpi ) )
          gpeucn = gpeucn + gpi ** 2
          if ( x(i) .gt. l(i) + macheps23 * max(1.0d0,abs(l(i))) .and.
     +         x(i) .lt. u(i) - macheps23 * max(1.0d0,abs(u(i))) ) then
              gisupn    = max( gisupn, abs( gpi ) )
              gieucn    = gieucn + gpi ** 2
              nind      = nind + 1
              if ( nind .gt. nindprev .or. ind(nind) .ne. i ) then
                  sameface = .false.
              end if
              ind(nind) = i
          end if
      end do
      xeucn  = sqrt( xeucn  )
      gpeucn = sqrt( gpeucn )
      gieucn = sqrt( gieucn )

C     Print information of this iteration

      if ( iprintinn .eq. 1 ) then
          if ( mod(iter,10) .eq. 0 ) then
              write(* ,1040)
              write(10,1040)
          end if
          write(* ,1060) iter,f,gpsupn,xsupn,ssupn,nind,lvfit,innit,fcnt
          write(10,1060) iter,f,gpsupn,xsupn,ssupn,nind,lvfit,innit,fcnt

      else if ( iprintinn .ge. 2 ) then
          write(* ,1070) iter,ittext(ittype)
          write(10,1070) iter,ittext(ittype)

          if ( iprintinn .ge. 3 ) then
              write(* ,1080) lvfit,innit,fcnt,cgcnt,nwcnt,trcnt,chcnt
              write(10,1080) lvfit,innit,fcnt,cgcnt,nwcnt,trcnt,chcnt
          end if

          write(* ,1090) f,gpsupn,gpeucn,gisupn,gieucn,xind,xsupn,xeucn,
     +                   ssupn,seucn
          write(10,1090) f,gpsupn,gpeucn,gisupn,gieucn,xind,xsupn,xeucn,
     +                   ssupn,seucn

          if ( iprintinn .ge. 4 .and. nprint .ne. 0 ) then
              write(* ,1100) min(nprint,nind),nind,
     +                       (ind(i),i=1,min(nprint,nind))
              write(* ,1110) nprint,(x(i),i=1,nprint)
              write(* ,1130) nprint,(g(i),i=1,nprint)
              write(* ,1140) nprint,(min(u(i),max(l(i),x(i)-g(i)))-x(i),
     +                       i=1,nprint)
              write(10,1100) min(nprint,nind),nind,
     +                       (ind(i),i=1,min(nprint,nind))
              write(10,1110) nprint,(x(i),i=1,nprint)
              write(10,1130) nprint,(g(i),i=1,nprint)
              write(10,1140) nprint,(min(u(i),max(l(i),x(i)-g(i)))-x(i),
     +                       i=1,nprint)
          end if
      end if

C     Save intermediate data for crash report

      if ( iprintctl(6) ) then
          open(20,file='gencan-tabline.out')
          write(20,1400) f,0.0d0,f,0.0d0,gpsupn,f,0.0d0,f,0.0d0,gpsupn,
     +                   0.0d0,0.0d0,inform,9,.false.,n,m,0,iter,fcnt,0,
     +                   0,0,0,999.9d0
          close(20)
      end if

C     ==================================================================
C     Test line-search and trust-region related stopping criteria
C     ==================================================================

C     Test whether the functional value is unbounded

      if ( ( ittype .le. 3 .and. lsinfo .eq. UNBOUNDED ) .or.
     +     ( ittype .eq. 4 .and. trinfo .eq. UNBOUNDED ) ) then
          geninfo = 6

          if ( iprintinn .ge. 1 ) then
              write(*, 1260)
              write(10,1260)
          end if

          return
      end if

C     ==================================================================
C     Iterate
C     ==================================================================

      go to 100

C     ==================================================================
C     End of main loop
C     ==================================================================

C     NON-EXECUTABLE STATEMENTS

 1000 format(/,5X,'Entry to GENCAN.',
     +       /,5X,'Number of variables: ',I7,
     +       /,5X,'Required optimality tolerance: ',1P,D7.1)

 1010 format(/,5X,'Lower bounds  (first ',I7,' components):',
     +       /,(5X, 6(1X,1P,D11.4)))
 1020 format(/,5X,'Upper bounds  (first ',I7,' components):',
     +       /,(5X, 6(1X,1P,D11.4)))
 1030 format(/,5X,'Initial point (first ',I7,' components):',
     +       /,(5X, 6(1X,1P,D11.4)))

 1040 format(/,5X,'It',16X,'f',2X,'gpsupn',3X,'xsupn',3X,'ssupn',4X,
     +            'nind',3X,'lvfit',3X,'innit',4X,'fcnt')
 1050 format(     I7,1X,1P,D16.8,2(1X,1P,D7.1))
 1060 format(     I7,1X,1P,D16.8,3(1X,1P,D7.1),4(1X,I7))

 1070 format(/,5X,'GENCAN ITERATION                  ',12X,'= ',I7,1X,
     +         A21)
 1080 format(/,5X,'Leaving-face iterations           ',12X,'= ',I7,
     +       /,5X,'Inner-to-the-face iterations      ',12X,'= ',I7,
     +       /,5X,'Functional evaluations            ',12X,'= ',I7,
     +       /,5X,'Conjugate gradient iterations     ',12X,'= ',I7,
     +       /,5X,'Newtonian system factorizations   ',12X,'= ',I7,
     +       /,5X,'Trust-region iterations           ',12X,'= ',I7,
     +       /,5X,'Trust-region matrix factorizations',12X,'= ',I7)

 1090 format(/,5X,'Functional value                              = ',
     +             1P,D24.16,
     +       /,5X,'Sup-norm of the continuous projected gradient = ',
     +             1P,D7.1,' 2-norm = ',1P,D7.1,
     +       /,5X,'Sup-norm of the internal projection of gp     = ',
     +             1P,D7.1,' 2-norm = ',1P,D7.1,
     +       /,5X,'Sup-norm of x (attained at x_{', I7,'})       = ',
     +             1P,D7.1,' 2-norm = ',1P,D7.1,
     +       /,5X,'Sup-norm of x - x_{prev}                      = ',
     +             1P,D7.1,' 2-norm = ',1P,D7.1)
 1100 format(/,5X,'Current free variables (first ',I7,', total ',
     +            'number ',I7,'): ',
     +       /,(5X, 6(1X,I7)))
 1110 format(/,5X,'Current point (first ',I7, ' components): ',
     +       /,(5X, 6(1X,1P,D11.4)))
 1130 format(/,5X,'Current gradient (first ',I7,' components): ',
     +       /,(5X, 6(1X,1P,D11.4)))
 1140 format(/,5X,'Current continuous projected gradient (first ',I7,
     +         5X,'components): ',
     +       /,(5X, 6(1X,1P,D11.4)))

 1200 format(/,5X,'Flag of GENCAN: Solution was found.',/)
 1210 format(/,5X,'Flag of GENCAN: Maximum of iterations reached.',/)
 1230 format(/,5X,'Flag of GENCAN: Lack of progress in the functional ',
     +            'value, its gradient and',/,5X,'the current point. ',
     +            'Probably, an exaggerated small norm of the ',
     +            'continuous',/,5X,'projected gradient is being ',
     +            'required to declare convergence.',/)
 1260 format(/,5X,'Flag of GENCAN: Objective function seems to be ',
     +            'unbounded.',/)
 1280 format(/,5X,'Flag of GENCAN: User-provided stopping criterion ',
     +            'satisfied.',/)

 1400 format(1X,1P,D24.16,1X,1P,D7.1,1X,1P,D24.16,1X,1P,D7.1,1X,1P,D7.1,
     +       1X,1P,D24.16,1X,1P,D7.1,1X,1P,D24.16,1X,1P,D7.1,1X,1P,D7.1,
     +       1X,1P,D7.1,1X,1P,D7.1,1X,I3,1X,I1,1X,L1,1X,I6,1X,I6,1X,I3,
     +       1X,I7,1X,I7,1X,I2,1X,I7,1X,I7,1X,I7,0P,F8.2)

      end


C     ******************************************************************
C     ******************************************************************

      subroutine compamax(nind,x,l,u,d,amax,rbdnnz,rbdind,rbdtype)

      implicit none

C     SCALAR ARGUMENTS
      integer nind,rbdnnz
      double precision amax

C     ARRAY ARGUMENTS
      integer rbdind(nind)
      character rbdtype(nind)
      double precision d(nind),l(nind),u(nind),x(nind)

C     Compute maximum step amax > 0 such that l <= x + amax d <= u.

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      double precision bignum,macheps,macheps12,macheps13,macheps23

C     COMMON BLOCKS
      common /machcon/ bignum,macheps,macheps12,macheps13,macheps23
      save   /machcon/

C     LOCAL SCALARS
      integer i
      double precision amaxi

      rbdnnz = 0

      amax = bignum

      do i = 1,nind
         if ( d(i) .gt. 0.0d0 ) then

             amaxi = ( u(i) - x(i) ) / d(i)

             if ( amaxi .lt. amax ) then
                 amax       = amaxi
                 rbdnnz     = 1
                 rbdind(1)  = i
                 rbdtype(1) = 'U'
             else if ( amaxi .eq. amax ) then
                 rbdnnz          = rbdnnz + 1
                 rbdind(rbdnnz)  = i
                 rbdtype(rbdnnz) = 'U'
             end if

         else if ( d(i) .lt. 0.0d0 ) then

             amaxi = ( l(i) - x(i) ) / d(i)

             if ( amaxi .lt. amax ) then
                 amax      = amaxi
                 rbdnnz     = 1
                 rbdind(1)  = i
                 rbdtype(1) = 'L'
             else if ( amaxi .eq. amax ) then
                 rbdnnz          = rbdnnz + 1
                 rbdind(rbdnnz)  = i
                 rbdtype(rbdnnz) = 'L'
             end if

         end if
      end do

      end
C     ******************************************************************
C     ******************************************************************

      subroutine newtd(nind,x,l,u,g,m,rho,equatn,d,adsupn,maxelem,
     +memfail,inform)

      implicit none

C     SCALAR ARGUMENTS
      logical memfail
      integer inform,nind,m
      double precision adsupn,maxelem

C     ARRAY ARGUMENTS
      logical equatn(m)
      double precision d(nind),g(*),l(*),rho(m),u(*),x(*)

C     This subroutine solves the Newtonian system
C
C             ( H + rho A^T A ) x = b
C
C     by solving the Martinez-Santos system
C
C             H x + A^t y = b
C             A x - y/rho = 0

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      double precision bignum,macheps,macheps12,macheps13,macheps23

C     COMMON BLOCKS
      common /machcon/ bignum,macheps,macheps12,macheps13,macheps23
      save   /machcon/
C     COMMON SCALARS
      character * 6 hptype
      character * 2 innslvr
      logical ccoded,fccoded,fcoded,gcoded,gjaccoded,innercall,jaccoded,
     +        hcoded,hccoded,hlcoded,hlpcoded,firstde,truehl,ignoref,
     +        skipacc,sclsys,useustp,safemode

C     COMMON BLOCKS
      common /algparam/ fcoded,gcoded,hcoded,ccoded,jaccoded,hccoded,
     +                  hlcoded,hlpcoded,fccoded,gjaccoded,firstde,
     +                  truehl,ignoref,skipacc,sclsys,innercall,useustp,
     +                  innslvr,hptype,safemode
      save   /algparam/
C     COMMON SCALARS
      logical iprintctl(7)
      integer iprintinn,iprintout,mprint,nprint

C     COMMON BLOCKS
      common /outdat/ iprintctl,iprintinn,iprintout,nprint,mprint
      save   /outdat/

C     COMMON SCALARS
      logical sameface
      integer ittype

C     COMMON BLOCKS
      common /itedat/ sameface,ittype
      save   /itedat/

C     PARAMETERS
      integer dimmax
      parameter ( dimmax = nmax + mmax )

C     COMMON ARRAYS
      double precision mindiag(nmax)

C     LOCAL SCALARS
      logical adddiff
      integer dim,hnnz,i,iter,lssinfo,nneigv,pind
      double precision diff,pval

C     LOCAL ARRAYS
      integer hdiag(dimmax),hlin(hnnzmax),hcol(hnnzmax)
      double precision adddiag(dimmax),adddiagprev(dimmax),
     +        hval(hnnzmax),sol(dimmax)

C     COMMON BLOCKS
      common /diadat/ mindiag
      save   /diadat/

C     ------------------------------------------------------------------
C     Presentation
C     ------------------------------------------------------------------

      if ( iprintinn .ge. 5 ) then
          write(* ,1000)
          write(10,1000)
      end if

C     ------------------------------------------------------------------
C     Initialization
C     ------------------------------------------------------------------

      iter    = 0
      memfail = .false.

      call lssini(sclsys,.true.,.false.)

C     ------------------------------------------------------------------
C     Compute ML matrix
C     ------------------------------------------------------------------

      call mlsyst(nind,x,g,m,rho,equatn,hlin,hcol,hval,hnnz,hdiag,sol,
     +dim,inform)

      if ( inform .lt. 0 ) return

      maxelem = 0.0d0
      do i = 1,hnnz
          maxelem = max( maxelem, abs( hval(i) ) )
      end do

C     ------------------------------------------------------------------
C     Analyse sparsity pattern
C     ------------------------------------------------------------------

      call lssana(dim,hnnz,hlin,hcol,hval,hdiag,lssinfo)

      if ( lssinfo .eq. 6 ) then
        ! INSUFFICIENT SPACE TO STORE THE LINEAR SYSTEM

          memfail = .true.
          return

      end if

C     ------------------------------------------------------------------
C     Main loop
C     ------------------------------------------------------------------

 100  continue

      iter = iter + 1

C     ------------------------------------------------------------------
C     Compute regularization
C     ------------------------------------------------------------------

      if ( iter .eq. 1 ) then

          if ( sameface .and. ittype .eq. 3 ) then

              do i = 1,nind
                  mindiag(i) = 0.1d0 * mindiag(i)
              end do

          else

              do i = 1,nind
                  if ( g(i) .eq. 0.0d0 ) then
                      mindiag(i) = 0.0d0
                  else
                      if ( g(i) .gt. 0.0d0 ) then
                          diff = x(i) - l(i)
                      else if ( g(i) .lt. 0.0d0 ) then
                          diff = u(i) - x(i)
                      end if
                      mindiag(i) = abs( g(i) / diff )
                  end if
              end do

          end if

          do i = 1,nind
              adddiag(i) = max( macheps23, mindiag(i) - hval(hdiag(i)) )
          end do

      else

          do i = 1,nind
              adddiagprev(i) = adddiag(i)
          end do

 110      continue

          do i = 1,nind
              if ( mindiag(i) .eq. 0.0d0 ) then
                  mindiag(i) = macheps23
              else
                  mindiag(i) = 10.0d0 * mindiag(i)
              end if
          end do

          do i = 1,nind
              adddiag(i) = max( macheps23, mindiag(i) - hval(hdiag(i)) )
          end do

          adddiff = .false.
          do i = 1,nind
              if ( adddiag(i) .gt. adddiagprev(i) ) then
                  adddiff = .true.
              end if
          end do

          if ( .not. adddiff ) then
              go to 110
          end if

      end if

      do i = nind + 1,dim
          adddiag(i) = 0.0d0
      end do

      adsupn = 0.0d0
      do i = 1,dim
          adsupn = max( adsupn, adddiag(i) )
      end do

      if ( iprintinn .ge. 5 ) then
          write(* ,1010) adsupn
          write(10,1010) adsupn
      end if

C     ------------------------------------------------------------------
C     Factorize matrix
C     ------------------------------------------------------------------

      call lssfac(dim,hnnz,hlin,hcol,hval,hdiag,adddiag,pind,pval,
     +nneigv,lssinfo)

      if ( lssinfo .eq. 0 .or. lssinfo .eq. 1 ) then

          if ( nneigv .ne. dim - nind ) then
C           ! WRONG INERTIA (SEE NOCEDAL AND WRIGHT)

C             Lemma 16.3 [pg. 447]: Assume that the Jacobian of the
C             constraints has full rank and that the reduced Hessian
C             Z^T H Z is positive definite. Then the Jacobian of the
C             KKT system has n positive eigenvalues, m negative
C             eigenvalues, and no zero eigenvalues.

C             Note that at this point we know that the matrix has no
C             zero eigenvalues. nneigv gives the number of negative
C             eigenvalues.

              if ( iprintinn .ge. 5 ) then
                  write(* ,1020) nneigv,dim - nind
                  write(10,1020) nneigv,dim - nind
              end if

              go to 100

          else

              if ( iprintinn .ge. 5 ) then
                  write(* ,1030)
                  write(10,1030)
              end if

          end if

      else if ( lssinfo .eq. 2 ) then
        ! SINGULAR JACOBIAN

          if ( iprintinn .ge. 5 ) then
              write(* ,1040)
              write(10,1040)
          end if

          go to 100

      else if ( lssinfo .eq. 6 ) then
        ! INSUFFICIENT SPACE TO STORE THE LINEAR SYSTEM

          memfail = .true.
          return

      else if ( lssinfo .eq. 7 ) then
        ! INSUFFICIENT DOUBLE PRECISION WORKING SPACE

          memfail = .true.
          return

      else ! if ( lssinfo .eq. 8 ) then
        ! INSUFFICIENT INTEGER WORKING SPACE

          memfail = .true.
          return

      end if

C     ------------------------------------------------------------------
C     Solve
C     ------------------------------------------------------------------

      call lsssol(dim,sol)

      do i = 1,nind
          d(i) = sol(i)
      end do

      if ( iprintinn .ge. 5 .and. nprint .ne. 0 ) then
          write(*, 1050) min0(nind,nprint),(d(i),i=1,min0(nind,nprint))
          write(10,1050) min0(nind,nprint),(d(i),i=1,min0(nind,nprint))
      end if

C     NON-EXECUTABLE STATEMENTS

 1000 format(/,5X,'Sparse factorization of the ML system.')
 1010 format(  5X,'Maximum value added to the diagonal: ',1P,D24.16)
 1020 format(  5X,'ML-matrix with wrong inertia.',
     +       /,5X,'Actual number of negative eigenvalues  = ',I16,'.',
     +       /,5X,'Desired number of negative eigenvalues = ',I16,'.')
 1030 format(  5X,'Direct solver finished successfully.')
 1040 format(  5X,'ML-matrix numerically singular.')
 1050 format(/,5X,'Newton direction (first ',I7,' components): ',
     +       /,1(5X,6(1X,1P,D11.4)))

      end

C     ******************************************************************
C     ******************************************************************

      subroutine mlsyst(nind,x,nal,m,rho,equatn,ulin,ucol,uval,unnz,
     +udiag,b,dim,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer dim,inform,m,nind,unnz

C     ARRAY ARGUMENTS
      logical equatn(m)
      integer ucol(*),udiag(*),ulin(*)
      double precision b(*),nal(nind),rho(m),uval(*),x(*)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical constrc,gotc

C     COMMON ARRAYS
      integer jcvar(jcnnzmax),jcsta(mmax),jclen(mmax)
      double precision c(mmax),dpdc(mmax),g(nmax),gparc(nmax),
     +        jcval(jcnnzmax)

C     COMMON BLOCKS
      common /gdata/ g,gparc,c,dpdc,jcval,jcvar,jcsta,jclen,constrc,gotc
      save   /gdata/
C     COMMON SCALARS
      integer nt

C     COMMON ARRAYS
      integer ind(nmax)
      double precision xcomplement(nmax)

C     COMMON BLOCKS
      common /rspace/ xcomplement,ind,nt
      save   /rspace/

C     LOCAL SCALARS
      integer col,i,j,k,lin,var

C     LOCAL ARRAYS
      integer wi(nmax)

C     This subrotuine is called from the reduced space.

C     MATRIX

C     Compute Hessian of the Lagrangian

      do i = 1,nt - nind
          x(nind+i) = xcomplement(i)
      end do

      call expand(nind,x)

      call sevalhl(nt,x,m,dpdc,ulin,ucol,uval,unnz,inform)
      if ( inform .lt. 0 ) return

      call shrink(nind,x)

C     Preparation for shrink (wi indicates, for each free variable x_i,
C     its rank within the set of free variables. wi(i)=0 if x_i is not
C     a free variable)

      do i = 1,nt
         wi(i) = 0
      end do

      do i = 1,nind
         wi(ind(i)) = i
      end do

C     Shrink Hessian of the Lagrangian and set diagonal-elements indices

      do i = 1,nind
          udiag(i) = 0
      end do

      k = 0

      do i = 1,unnz
          lin = wi(ulin(i))
          col = wi(ucol(i))

          if ( lin .ne. 0 .and. col .ne. 0 ) then
              k = k + 1
              ulin(k) = lin
              ucol(k) = col
              uval(k) = uval(i)

              if ( lin .eq. col ) then
                  udiag(lin) = k
              end if
          end if
      end do

      do i = 1,nind
          if ( udiag(i) .eq. 0 ) then
              k = k + 1
              ulin(k) = i
              ucol(k) = i
              uval(k) = 0.0d0

              udiag(i) = k
          end if
      end do

C     Shrink Jacobian and add diagonal matrix - 1.0 / rho

      dim = nind

      do j = 1,m
          if ( equatn(j) .or. dpdc(j) .gt. 0.0d0 ) then

              dim = dim + 1

              do i = jcsta(j),jcsta(j) + jclen(j) - 1
                  var = wi(jcvar(i))

                  if ( var .ne. 0 ) then
                      k = k + 1
                      ulin(k) = dim
                      ucol(k) = var
                      uval(k) = jcval(i)
                  end if
              end do

              k = k + 1
              ulin(k) = dim
              ucol(k) = dim
              uval(k) = - 1.0d0 / rho(j)

              udiag(dim) = k
          end if
      end do

      unnz = k

C     RHS

      do i = 1,nind
          b(i) = - nal(i)
      end do

      do i = nind + 1,dim
          b(i) = 0.0d0
      end do

      end
C     ******************************************************************
C     ******************************************************************

      subroutine cgm(nind,x,m,lambda,rho,equatn,linear,l,u,g,delta,
     +eps,maxit,precond,d,rbdnnz,rbdind,rbdtype,iter,cginfo,inform)

      implicit none

C     SCALAR ARGUMENTS
      character * 6 precond
      integer cginfo,inform,iter,m,maxit,nind,rbdnnz
      double precision delta,eps

C     ARRAY ARGUMENTS
      logical equatn(m),linear(m)
      integer rbdind(nind)
      character rbdtype(nind)
      double precision d(nind),g(nind),l(nind),lambda(m),rho(m),u(nind),
     +        x(*)

C     This subroutine implements the Conjugate Gradients method for
C     minimizing the quadratic approximation q(d) of L(x,lambda,rho)
C     at x
C
C     q(d) = 1/2 d^T H d + g^T d,
C
C     where H is an approximation of the Hessian matrix of the
C     Augmented Lagrangian and g is its gradient vector,
C
C     subject to || d || <= delta and l <= x + d <= u.
C
C     In the constraint ''|| d || <= delta'', the norm will be the
C     Euclidian-norm if the input parameter trtype is equal to 0, and
C     it will be the sup-norm if trtype is equal to 1.
C
C     The method returns an approximation d of the solution such that
C
C     (a) ||H d + g||_2 <= eps * ||g||_2,
C
C     (b) ||d|| = delta or x + d is in the boundary of the box, or
C
C     (c) ( p such that p^t H p = 0 ) and ( d = - amax g if such p was
C         found during the first CG iteration or the current point d
C         of CG if such p was found in any other iteration ).
C
C     inform   integer
C              termination parameter:
C
C              0 = convergence with ||H d + g||_2 <= eps * ||g||_2;
C
C              1 = convergence to the boundary of ||d|| <= delta;
C
C              2 = convergence to the boundary of l <= x + d <= u;
C
C              3 = stopping with d = dk  such that <gk,dk> <= - theta
C                  ||gk||_2 ||dk||_2 and <gk,d_{k+1}> > - theta
C                  ||gk||_2 ||d_{k+1}||_2;
C
C              4 = not enough progress of the quadratic model during
C                  maxitnqmp iterations, i.e., during maxitnqmp
C                  iterations | q - qprev | <= macheps * max( | q |, 1 )
C
C              6 = very similar consecutive iterates, for two
C                  consecutive iterates x1 and x2 we have that
C
C                  | x2(i) - x1(i) | <= macheps * max ( | x1(i) |, 1 )
C
C                  for all i.
C
C              7 = stopping with p such that p^T H p = 0 and g^T p = 0;
C
C              8 = too many iterations;

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      double precision bignum,macheps,macheps12,macheps13,macheps23

C     COMMON BLOCKS
      common /machcon/ bignum,macheps,macheps12,macheps13,macheps23
      save   /machcon/
C     PARAMETERS

C     General constants

      double precision fmin

      parameter ( fmin       = - 1.0d+20 )

C     Line search constants

      integer maxextrap,mininterp
      double precision beta,etaint,etaext,gamma,sigma1,sigma2

      parameter ( maxextrap  =       100 )
      parameter ( mininterp  =         4 )

      parameter ( gamma      =   1.0d-04 )
      parameter ( beta       =     0.5d0 )
      parameter ( sigma1     =     0.1d0 )
      parameter ( sigma2     =     0.9d0 )
      parameter ( etaint     =     2.0d0 )
      parameter ( etaext     =     2.0d0 )

C     Safeguarding spectral step constants

      double precision lspgma,lspgmi

      parameter ( lspgma     =   1.0d+10 )
      parameter ( lspgmi     =   1.0d-10 )

C     Conjugate gradients constants

      integer maxcgitnp
      double precision epsnqmp,theta

      parameter ( theta      =   1.0d-06 )
      parameter ( epsnqmp    =   1.0d-08 )
      parameter ( maxcgitnp  =         5 )

C     BETRA constants

      logical extrp4,extrp5
      integer msmaxit
      double precision mseps,msrho,mssig,phieps,trdelini,trdelmin,
     +        tralpha

      parameter ( extrp4     =   .true. )
      parameter ( extrp5     =   .true. )

      parameter ( msmaxit    =       20 )

      parameter ( mseps      =  1.0d-08 )
      parameter ( mssig      =  1.0d-01 )
      parameter ( msrho      =  9.0d-01 )
      parameter ( phieps     =  1.0d-08 )
      parameter ( trdelini   =  1.0d+02 )
      parameter ( trdelmin   =  1.0d-08 )
      parameter ( tralpha    =  1.0d-01 )

C     GENCAN constants

      integer maxinnitnp
      double precision cggpnf,cgepsi,cgepsf,delmin,eta

      parameter ( maxinnitnp =         3 )
      parameter ( delmin     =   1.0d+04 )
      parameter ( eta        =   0.1d0   )
      parameter ( cggpnf     =   1.0d-04 )
      parameter ( cgepsi     =   1.0d-01 )
      parameter ( cgepsf     =   1.0d-08 )

C     ALGENCAN constants

      logical rhorestart
      integer maxoutitnp,maxoutit
      double precision lammax,lammin,rhofrac,rhoinimax,rhoinimin,rhomax,
     +        rhomult

      parameter ( maxoutitnp =        10 )
      parameter ( maxoutit   =       100 )

      parameter ( lammin     = - 1.0d+20 )
      parameter ( lammax     =   1.0d+20 )

      parameter ( rhofrac    =   0.5d0   )
      parameter ( rhomult    =   1.0d+01 )
      parameter ( rhomax     =   1.0d+20 )

      parameter ( rhorestart =    .true. )
      parameter ( rhoinimin  =   1.0d-08 )
      parameter ( rhoinimax  =   1.0d+08 )
C     COMMON SCALARS
      character * 6 hptype
      character * 2 innslvr
      logical ccoded,fccoded,fcoded,gcoded,gjaccoded,innercall,jaccoded,
     +        hcoded,hccoded,hlcoded,hlpcoded,firstde,truehl,ignoref,
     +        skipacc,sclsys,useustp,safemode

C     COMMON BLOCKS
      common /algparam/ fcoded,gcoded,hcoded,ccoded,jaccoded,hccoded,
     +                  hlcoded,hlpcoded,fccoded,gjaccoded,firstde,
     +                  truehl,ignoref,skipacc,sclsys,innercall,useustp,
     +                  innslvr,hptype,safemode
      save   /algparam/
C     COMMON SCALARS
      logical iprintctl(7)
      integer iprintinn,iprintout,mprint,nprint

C     COMMON BLOCKS
      common /outdat/ iprintctl,iprintinn,iprintout,nprint,mprint
      save   /outdat/


C     LOCAL SCALARS
      character * 6 prectmp
      logical goth,gotp,negcur,restarted,samep
      integer i,itertmp,itnqmp
      double precision alpha,abox,amax,amaxbds,amaxbdsi,amaxdel,
     +        bestprog,bbeta,currprog,dnorm2,gnorm2,gtd,gtp,pnorm2,ptd,
     +        pthp,ptr,q,qprev,rnorm2,ztrprev,ztr,znorm2

C     LOCAL ARRAYS
      double precision p(nmax),hp(nmax),r(nmax),z(nmax)

C     ==================================================================
C     Initialization
C     ==================================================================

      restarted = .false.

 001  continue

      goth = .false.
      gotp = .false.

C     gnorm2 = norm2s(nind,g)
      gnorm2 = 0.0d0
      do i = 1,nind
          gnorm2 = gnorm2 + g(i) ** 2
      end do

      iter     =      0
      itnqmp   =      0
      qprev    = bignum
      bestprog =  0.0d0

      do i = 1,nind
          d(i) = 0.0d0
          r(i) =  g(i)
      end do

      q        =  0.0d0
      gtd      =  0.0d0
      dnorm2   =  0.0d0
      rnorm2   = gnorm2

      ztr      =  0.0d0

C     ==================================================================
C     Print initial information
C     ==================================================================

      if ( iprintinn .ge. 5 ) then
          write(*, 980) maxit,eps,delta,precond,hptype
          write(*, 984) iter,sqrt(rnorm2),sqrt(dnorm2),q

          write(10,980) maxit,eps,delta,precond,hptype
          write(10,984) iter,sqrt(rnorm2),sqrt(dnorm2),q
      end if

C     ==================================================================
C     Main loop
C     ==================================================================

 100  continue

C     ==================================================================
C     Test stopping criteria
C     ==================================================================

C     if ||r||_2 = ||H d + g||_2 <= eps * ||g||_2 then stop

      if ( iter .ne. 0 .and.
     +   ( ( rnorm2 .le. eps ** 2 * gnorm2 .and. iter .ge. 4 ) .or.
     +     ( rnorm2 .le. macheps ) ) ) then

          cginfo = 0

          if ( iprintinn .ge. 5 ) then
              write(*, 990)
              write(10,990)
          end if

          go to 500

      end if

C     if the maximum number of iterations was achieved then stop

      if ( iter .ge. max(4, maxit) ) then

          cginfo = 8

          if ( iprintinn .ge. 5 ) then
              write(*, 998)
              write(10,998)
          end if

          go to 500

      end if

C     ==================================================================
C     Preconditioner
C     ==================================================================

      if ( precond .eq. 'NONE' ) then

          do i = 1,nind
              z(i) = r(i)
          end do

          ztrprev = ztr
          ztr     = rnorm2
          znorm2  = rnorm2

      else if ( precond .eq. 'QNCGNA' ) then

          call capplyhpre(nind,m,rho,equatn,gotp,r,z)

          ztrprev = ztr

          ztr = 0.0d0
          do i = 1,nind
              ztr = ztr + z(i) * r(i)
          end do

C         znorm2 = norm2s(nind,z)
          znorm2 = 0.0d0
          do i = 1,nind
              znorm2 = znorm2 + z(i) ** 2
          end do

      end if

C     ==================================================================
C     Compute direction
C     ==================================================================

      if ( iter .eq. 0 ) then

          do i = 1,nind
              p(i) = - z(i)
          end do

          ptr    = - ztr
          pnorm2 =   znorm2

      else

          bbeta = ztr / ztrprev

          do i = 1,nind
              p(i) = - z(i) + bbeta * p(i)
          end do

          if ( precond .eq. 'NONE' ) then

              pnorm2 = rnorm2 - 2.0d0 * bbeta * ( ptr + alpha * pthp )
     +               + bbeta ** 2 * pnorm2
              ptr = - rnorm2 + bbeta * ( ptr + alpha * pthp )

          else if ( precond .eq. 'QNCGNA' ) then

              ptr = 0.0d0
              pnorm2 = 0.0d0
              do i = 1,nind
                  ptr = ptr + p(i) * r(i)
                  pnorm2 = pnorm2 + p(i) ** 2
              end do

          end if

      end if

C     Force p to be a descent direction of q(d), i.e.,
C     <\nabla q(d), p> = <H d + g, p> = <r, p> \le 0.

      if ( ptr .gt. 0.0d0 ) then

          do i = 1,nind
              p(i) = - p(i)
          end do

          ptr = - ptr

      end if

C     ==================================================================
C     Compute p^T H p
C     ==================================================================

C     hp = H p

      call calchalp(nind,x,m,lambda,rho,equatn,linear,p,hp,goth,inform)
      if ( inform .lt. 0 ) return

C     Compute p^T hp

      pthp = 0.0d0
      do i = 1,nind
          pthp = pthp + p(i) * hp(i)
      end do

C     ==================================================================
C     Compute maximum steps
C     ==================================================================

      amaxdel = bignum

      do i = 1,nind
          if ( p(i) .gt. 0.0d0 ) then
              amaxdel = min( amaxdel,  (   delta - d(i) ) / p(i) )
          else if ( p(i) .lt. 0.0d0 ) then
              amaxdel = min( amaxdel,  ( - delta - d(i) ) / p(i) )
          end if
      end do

      amaxbds = bignum

C     do i = 1,nind
C        if ( p(i) .gt. 0.0d0 ) then

C            amaxbdsi = ( u(i) - d(i) - x(i) ) / p(i)

C            if ( amaxbdsi .lt. amaxbds ) then
C                amaxbds    = amaxbdsi
C                rbdnnz     = 1
C                rbdind(1)  = i
C                rbdtype(1) = 'U'
C            else if ( amaxbdsi .eq. amaxbds ) then
C                rbdnnz          = rbdnnz + 1
C                rbdind(rbdnnz)  = i
C                rbdtype(rbdnnz) = 'U'
C            end if

C        else if ( p(i) .lt. 0.0d0 ) then

C            amaxbdsi = ( l(i) - d(i) - x(i) ) / p(i)

C            if ( amaxbdsi .lt. amaxbds ) then
C                amaxbds    = amaxbdsi
C                rbdnnz     = 1
C                rbdind(1)  = i
C                rbdtype(1) = 'L'
C            else if ( amaxbdsi .eq. amaxbds ) then
C                rbdnnz          = rbdnnz + 1
C                rbdind(rbdnnz)  = i
C                rbdtype(rbdnnz) = 'L'
C            end if

C        end if
C     end do

      amax = min( amaxdel, amaxbds )

C     ==================================================================
C     Compute the step
C     ==================================================================

      negcur = .false.

C     If p^T H p > 0 then take the conjugate gradients step

      if ( pthp .gt. 0.0d0 ) then

          alpha = min( amax, ztr / pthp )

C     Else, if we are at iteration zero then take the maximum
C     positive step in the minus gradient direction

      else if ( iter .eq. 0 ) then

          alpha = amax

          negcur = .true.

C     Otherwise, stop at the current iterate

      else

          cginfo = 7

          if ( iprintinn .ge. 5 ) then
              write(*, 997)
              write(10,997)
          end if

          go to 500

      end if

C     ==================================================================
C     Test the angle condition
C     ==================================================================

      ptd = 0.0d0
      gtp = 0.0d0
      do i = 1,nind
          ptd = ptd + p(i) * d(i)
          gtp = gtp + g(i) * p(i)
      end do

C     These are gtd and dnorm2 for the new direction d which was not
C     computed yet.
      gtd = gtd + alpha * gtp
      dnorm2 = dnorm2 + alpha ** 2 * pnorm2 + 2.0d0 * alpha * ptd

      if ( gtd .gt. 0.0d0 .or.
     +     gtd ** 2 .lt. theta ** 2 * gnorm2 * dnorm2 ) then

          if ( precond .ne. 'NONE' .and. iter .eq. 0 ) then

              if ( iprintinn .ge. 5 ) then
                  write(*, 986)
                  write(10,986)
              end if

              restarted = .true.
              itertmp   = iter
              prectmp   = precond
              precond   = 'NONE'
              go to 001

          end if

          cginfo = 3

          if ( iprintinn .ge. 5 ) then
              write(*, 993)
              write(10,993)
          end if

          go to 500

      end if

C     ==================================================================
C     Compute the quadratic model functional value at the new point
C     ==================================================================

      qprev = q

      q = q + 0.5d0 * alpha ** 2 * pthp + alpha * ptr

C     ==================================================================
C     Compute new d
C     ==================================================================

      do i = 1,nind
          d(i) = d(i) + alpha * p(i)
      end do

C     ==================================================================
C     Compute the residual r = H d + g
C     ==================================================================

      do i = 1,nind
          r(i) = r(i) + alpha * hp(i)
      end do

C     rnorm2 = norm2s(nind,r)
      rnorm2 = 0.0d0
      do i = 1,nind
          rnorm2 = rnorm2 + r(i) ** 2
      end do

C     ==================================================================
C     Increment number of iterations
C     ==================================================================

      iter = iter + 1

C     ==================================================================
C     Print information of this iteration
C     ==================================================================

      if ( iprintinn .ge. 5 ) then
          write(*, 984) iter,sqrt(rnorm2),sqrt(dnorm2),q
          write(10,984) iter,sqrt(rnorm2),sqrt(dnorm2),q
      end if

C     ==================================================================
C     Test other stopping criteria
C     ==================================================================

C     Boundary of the "trust region"

      if ( alpha .eq. amaxdel ) then

          cginfo = 1

          if ( iprintinn .ge. 5 ) then
              if ( negcur ) then
                  write(*, 987)
                  write(10,987)
              end if

              write(*, 991)
              write(10,991)
          end if

          go to 500

      end if

C     Boundary of the box constraints

C     if ( alpha .eq. amaxbds ) then

C         cginfo = 2

C         if ( iprintinn .ge. 5 ) then
C             if ( negcur ) then
C                 write(*, 987)
C                 write(10,987)
C             end if

C             write(*, 992)
C             write(10,992)
C         end if

C         go to 500

C     end if

C     Small useful proportion

      abox = bignum

      do i = 1,nind
         if ( d(i) .gt. 0.0d0 ) then
             abox = min( abox, ( u(i) - x(i) ) / d(i) )
         else if ( d(i) .lt. 0.0d0 ) then
             abox = min( abox, ( l(i) - x(i) ) / d(i) )
         end if
      end do

      if ( abox .le. 0.1d0 ) then

          cginfo = 5

          if ( iprintinn .ge. 5 ) then
              write(* ,995)
              write(10,995)
          end if

          go to 500

      end if

C     Two consecutive iterates are too much close

      samep = .true.
      do i = 1,nind
         if ( abs( alpha * p(i) ) .gt.
     +        macheps * max( 1.0d0, abs( d(i) ) ) ) then
             samep = .false.
          end if
      end do

      if ( samep ) then

          cginfo = 6

          if ( iprintinn .ge. 5 ) then
              write(*, 996)
              write(10,996)
          end if

          go to 500

      end if

C     Many iterations without good progress of the quadratic model

      currprog = qprev - q
      bestprog = max( currprog, bestprog )

      if ( currprog .le. epsnqmp * bestprog ) then

          itnqmp = itnqmp + 1

          if ( itnqmp .ge. maxcgitnp ) then
              cginfo = 4

              if ( iprintinn .ge. 5 ) then
                  write(*, 994)
                  write(10,994)
              end if

              go to 500
          endif

      else
          itnqmp = 0
      endif

C     ==================================================================
C     Iterate
C     ==================================================================

      go to 100

C     ==================================================================
C     End of main loop
C     ==================================================================

C     ==================================================================
C     Return
C     ==================================================================

 500  continue

C     Print final information

      if ( iprintinn .ge. 5 .and. nprint .ne. 0 ) then
          write(*, 985) min0(nind,nprint),(d(i),i=1,min0(nind,nprint))
          write(10,985) min0(nind,nprint),(d(i),i=1,min0(nind,nprint))
      end if

      if ( restarted ) then
          iter = iter + itertmp
          precond = prectmp
      end if

      return

C     Non-executable statements

 980  format(/,5X,'Conjugate Gradients (maxit = ',I7,',',1X,'eps = ',
     +            1P,D7.1,',',1X,'delta = ',1P,D7.1,')',
     +       /,5X,'(Preconditioner: ',A6,',',1X,
     +            'Hessian-vector product type: ',A6,')')
 984  format(  5X,'CG iter = ',I7,' rnorm = ',1P,D10.4,' dnorm = ',
     +            1P,D10.4,' q = ',1P,D11.4)
 985  format(/,5X,'Truncated Newton direction (first ',I7,
     +            ' components): ',/,1(5X,6(1X,1P,D11.4)))
 986  format(  5X,'The first CG-PREC iterate did not satisfy the ',
     +            'angle condition.',
     +       /,5X,'CG will be restarted without preconditioner)')
 987  format(  5X,'p such that p^T H p = 0 was found. ',
     +            'Maximum step was taken.')

 990  format(  5X,'Flag of CG: Convergence with small residual.')
 991  format(  5X,'Flag of CG: Convergence to the trust region ',
     +            'boundary.')
C992  format(  5X,'Flag of CG: Convergence to the box boundary.')
 993  format(  5X,'Flag of CG: The next CG iterate will not satisfy ',
     +            'the angle condition.')
 994  format(  5X,'Flag of CG: Not enough progress in the quadratic ',
     +            'model.')
 995  format(  5X,'Flag of CG: The maximum step to remain within the ',
     +            'box is smaller than 0.1)')
 996  format(  5X,'Flag of CG: Very near consecutive iterates.')
 997  format(  5X,'Flag of CG: p such that p^T H p = 0 was found.')
 998  format(  5X,'Flag of CG: Maximum number of CG iterations ',
     +            'reached.')

      end
C     *****************************************************************
C     *****************************************************************

      subroutine betra(n,nind,x,l,u,m,lambda,rho,equatn,linear,f,g,
     +trdelta,newdelta,mslamb,epsg,xeucn,xsupn,gpsupn,d,rbdind,rbdtype,
     +xtrial,ftrial,gtrial,triter,chcnt,memfail,betinfo,inform)

      implicit none

C     SCALAR ARGUMENTS
      logical memfail
      integer betinfo,chcnt,inform,m,n,nind,triter
      double precision epsg,f,ftrial,gpsupn,mslamb,newdelta,trdelta,
     +        xeucn,xsupn

C     ARRAY ARGUMENTS
      logical equatn(m),linear(m)
      character rbdtype(nind)
      integer rbdind(nind)
      double precision d(nind),g(n),gtrial(n),l(n),lambda(m),rho(m),
     +        u(n),x(n),xtrial(n)

C     Solves the "unconstrained" inner problem that arises from the 
C     active-set method to solve box-constrained minimization problem
C
C            Minimize f(x) subject to l <= x <= u
C     
C     described in 
C
C     M. Andretta, E. G. Birgin e J. M. Martínez. "Practical active-set 
C     Euclidian trust-region method with spectral projected gradients 
C     for bound-constrained minimization". Optimization 54, pp. 
C     305-325, 2005.

C     betinfo:
C
C     0: Sufficient decrease of the function
C     1: x hits the boundary
C     2: Unbounded objective function?
C     3: Either the search direction or the step lenght is too small
C     4: Trust-region radius too small
C     5: Undefined direction
C     6: x is a first-order stationary point close to the boundary
C     7: x is a second-order stationary point
C     8: x is too close to the boundary

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     PARAMETERS

C     General constants

      double precision fmin

      parameter ( fmin       = - 1.0d+20 )

C     Line search constants

      integer maxextrap,mininterp
      double precision beta,etaint,etaext,gamma,sigma1,sigma2

      parameter ( maxextrap  =       100 )
      parameter ( mininterp  =         4 )

      parameter ( gamma      =   1.0d-04 )
      parameter ( beta       =     0.5d0 )
      parameter ( sigma1     =     0.1d0 )
      parameter ( sigma2     =     0.9d0 )
      parameter ( etaint     =     2.0d0 )
      parameter ( etaext     =     2.0d0 )

C     Safeguarding spectral step constants

      double precision lspgma,lspgmi

      parameter ( lspgma     =   1.0d+10 )
      parameter ( lspgmi     =   1.0d-10 )

C     Conjugate gradients constants

      integer maxcgitnp
      double precision epsnqmp,theta

      parameter ( theta      =   1.0d-06 )
      parameter ( epsnqmp    =   1.0d-08 )
      parameter ( maxcgitnp  =         5 )

C     BETRA constants

      logical extrp4,extrp5
      integer msmaxit
      double precision mseps,msrho,mssig,phieps,trdelini,trdelmin,
     +        tralpha

      parameter ( extrp4     =   .true. )
      parameter ( extrp5     =   .true. )

      parameter ( msmaxit    =       20 )

      parameter ( mseps      =  1.0d-08 )
      parameter ( mssig      =  1.0d-01 )
      parameter ( msrho      =  9.0d-01 )
      parameter ( phieps     =  1.0d-08 )
      parameter ( trdelini   =  1.0d+02 )
      parameter ( trdelmin   =  1.0d-08 )
      parameter ( tralpha    =  1.0d-01 )

C     GENCAN constants

      integer maxinnitnp
      double precision cggpnf,cgepsi,cgepsf,delmin,eta

      parameter ( maxinnitnp =         3 )
      parameter ( delmin     =   1.0d+04 )
      parameter ( eta        =   0.1d0   )
      parameter ( cggpnf     =   1.0d-04 )
      parameter ( cgepsi     =   1.0d-01 )
      parameter ( cgepsf     =   1.0d-08 )

C     ALGENCAN constants

      logical rhorestart
      integer maxoutitnp,maxoutit
      double precision lammax,lammin,rhofrac,rhoinimax,rhoinimin,rhomax,
     +        rhomult

      parameter ( maxoutitnp =        10 )
      parameter ( maxoutit   =       100 )

      parameter ( lammin     = - 1.0d+20 )
      parameter ( lammax     =   1.0d+20 )

      parameter ( rhofrac    =   0.5d0   )
      parameter ( rhomult    =   1.0d+01 )
      parameter ( rhomax     =   1.0d+20 )

      parameter ( rhorestart =    .true. )
      parameter ( rhoinimin  =   1.0d-08 )
      parameter ( rhoinimax  =   1.0d+08 )
C     COMMON SCALARS
      integer efcnt,efccnt,egcnt,egjccnt,ehcnt,ehlcnt,ehlpcnt,fcnt

C     COMMON ARRAYS
      integer eccnt(mmax),ehccnt(mmax),ejccnt(mmax)

C     COMMON BLOCKS
      common /counters/ eccnt,ehccnt,ejccnt,efcnt,efccnt,egcnt,egjccnt,
     +                  ehcnt,ehlcnt,ehlpcnt,fcnt
      save   /counters/
C     COMMON SCALARS
      integer hnnz

C     COMMON ARRAYS
      integer hcol(hnnzmax),hlin(hnnzmax)
      double precision hval(hnnzmax)

C     COMMON BLOCKS
      common /hdata/ hval,hlin,hcol,hnnz
      save   /hdata/
C     COMMON SCALARS
      logical sameface
      integer ittype

C     COMMON BLOCKS
      common /itedat/ sameface,ittype
      save   /itedat/
C     COMMON SCALARS
      double precision bignum,macheps,macheps12,macheps13,macheps23

C     COMMON BLOCKS
      common /machcon/ bignum,macheps,macheps12,macheps13,macheps23
      save   /machcon/
C     COMMON SCALARS
      logical iprintctl(7)
      integer iprintinn,iprintout,mprint,nprint

C     COMMON BLOCKS
      common /outdat/ iprintctl,iprintinn,iprintout,nprint,mprint
      save   /outdat/

C     COMMON SCALARS
      double precision seucn,sts,sty,yeucn

C     COMMON ARRAYS
      double precision s(nmax),y(nmax)

C     COMMON BLOCKS
      common /sydata/ s,y,seucn,yeucn,sts,sty
      save   /sydata/

C     LOCAL SCALARS
      logical frstit,pd,samep
      integer dinfo,extinfo,i,col,lin,index,lsinfo,rbdnnz
      double precision amax,ared,dbound,deucn,gsupn,lamspg,phi,pred,
     +        stpl,tmp

C     LOCAL ARRAYS
      integer hdiag(nmax)

C     EXTERNAL SUBROUTINES
      external calcal,csetp

C     Print presentation information

      if ( iprintinn .ge. 5 ) then
          write(*, 1000)
          write(10,1000)
      end if
      
C     Initialization

      if ( .not. sameface ) then
          trdelta = max( trdelta, newdelta )
      end if
      
      newdelta = 0.0d0
      
      memfail  = .false.

      frstit   = .true.

C     ==================================================================
C     Compute distance to the boundary
C     ==================================================================
      
C     step 1: calculate the distance between x and the boundary.
C             dbound is the largest positive delta such that the ball 
C             centered at x with radius delta is still inside the box 
C             (set of constraints).

      dbound = bignum

      do i = 1,nind
          dbound = min( dbound, x(i) - l(i) )
      end do
      
      do i = 1,nind
          dbound = min( dbound, u(i) - x(i) )
      end do

C     Calculate infinite-norm of gradient.

      gsupn = 0.0d0
      do i = 1,nind
          gsupn = max( gsupn, abs( g(i) ) )
      end do

C     ==================================================================
C     Close to the boundary: perform inner SPG iteration
C     ==================================================================
      
C     step 2: close to the boundary, stop.

      if ( dbound .lt. 2.0d0 * trdelmin ) then

          do i = 1,n
              xtrial(i) = x(i)
              gtrial(i) = g(i)
          end do
              
          ftrial  = f

          betinfo = 8
              
          if ( iprintinn .ge. 5 ) then
              write(*, 9010) 
              write(10,9010) 
          end if
              
          return

      end if

C     ==================================================================
C     Far from the boundary: perform trust-region iteration
C     ==================================================================
      
      triter = triter + 1

C     step 3: far from the boundary, solve trust-region subproblem. 
C             Evaluate function Hessian at x.

      call calchal(nind,x,m,lambda,rho,equatn,linear,hlin,hcol,hval,
     +hnnz,inform)
      if ( inform .lt. 0 ) return
      
      do i = 1,nind
          hdiag(i) = 0
      end do

      do i = 1,hnnz
          lin = hlin(i)
          col = hcol(i)

          if ( lin .eq. col ) then
              if ( hdiag(lin) .eq. 0 ) then
                  hdiag(lin) = i
              else
                  hval(hdiag(lin)) = hval(hdiag(lin)) + hval(i)
                  hval(i) = 0.0d0
              end if 
          end if
      end do

      do i = 1,nind
         if ( hdiag(i) .eq. 0 ) then
            hnnz       = hnnz + 1            
            hlin(hnnz) = i
            hcol(hnnz) = i
            hval(hnnz) = 0.0d0
            hdiag(i)   = hnnz
         end if
      end do

C     step 4: solve the trust-region subproblem using More-Sorensen's 
C             algorithm to minimize "exactly" quadratics subjected to 
C             balls. 

C     If trust-region radius is too small, the inner algorithm stops.

 100  continue

      if ( trdelta .lt. macheps * max( 1.0d0, xeucn ) ) then

          do i = 1,n
              xtrial(i) = x(i)
              gtrial(i) = g(i)
          end do
          
          ftrial  = f

          betinfo = 4
          
          if ( iprintinn .ge. 5 ) then
              write(*, 9040) 
              write(10,9040) 
          end if
          
          return
      end if
      
      call moresor(nind,g,hnnz,hlin,hcol,hval,hdiag,trdelta,mssig,
     +0.0d0,mseps,msmaxit,mslamb,pd,d,chcnt,memfail,dinfo)

      if ( memfail ) then
          return
      end if

C     If maximum allowed number of MEQB iterations is achieved, another
C     direction d is calculated.

      if ( dinfo .eq. 5 ) then 
          
          if ( iprintinn .ge. 5 ) then
              write(*, 2000)
              write(10,2000)
          end if

          call dogleg(nind,g,hnnz,hlin,hcol,hval,pd,trdelta,d,dinfo)

      end if
      
C     If both internal gradient and Hessian matrix are null, subroutines 
C     MEQB and dogleg stop with dinfo = 0 and then the inner algorithm 
C     stops declaring "second-order stationary point".

      if ( dinfo .eq. 0 ) then

          do i = 1,n
              xtrial(i) = x(i)
              gtrial(i) = g(i)
          end do
          
          ftrial  = f

          betinfo = 7
          
          if ( iprintinn .ge. 5 ) then
              write(*, 9020) 
              write(10,9020) 
          end if
          
          return
      end if
      
C     Print direction

      if ( iprintinn .ge. 5 ) then
          write(*, 1020) min0(nind,nprint),(d(i),i=1,min0(nind,nprint))
          write(10,1020) min0(nind,nprint),(d(i),i=1,min0(nind,nprint))
      end if

C     Evaluate the quadratic model of the objective function at d.

      call squad(nind,d,g,hnnz,hlin,hcol,hval,phi)

C     If the value of the quadratic model at d is 0 it means that x is a 
C     second-order stationary point. In this case, inner algorithm stops
C     declaring this.
      
      if ( ( abs( phi ) .le. phieps ) .and. ( gsupn .le. epsg ) ) then

          do i = 1,n
              xtrial(i) = x(i)
              gtrial(i) = g(i)
          end do
          
          ftrial  = f

          betinfo = 7
          
          if ( iprintinn .ge. 5 ) then
              write(*, 9020) 
              write(10,9020) 
          end if
          
          return
      end if
      
C     Calculate predicted decrease of objective function
      
      pred = abs( phi )
      
C     Calculate d Euclidian-norm
      
      deucn = 0.0d0
      do i = 1,nind
          deucn = deucn + d(i)**2
      end do
      deucn = sqrt( deucn )
      
C     To avoid NaN and Inf directions

      if ( .not. ( deucn .le. bignum ) ) then
      
          trdelta = 2.5d-1 * trdelta

          if ( iprintinn .ge. 5 ) then
              write(*, 2060) 
              write(10,2060) 
          end if

          if ( trdelta .lt. macheps * max( 1.0d0, xeucn ) ) then

              do i = 1,n
                  xtrial(i) = x(i)
                  gtrial(i) = g(i)
              end do
              
              ftrial  = f

              betinfo = 5
              
              if ( iprintinn .ge. 5 ) then
                  write(*, 9070) 
                  write(10,9070) 
              end if
              
              return
          end if

          triter  = triter + 1
          frstit  = .false.

          go to 100

      end if

C     Calculate point xtrial = x + d.
      
      do i = 1,nind
          xtrial(i) = x(i) + d(i)
      end do

      stpl = 1.0d0

C     Verify if xtrial is inside de box. If not, interior is set to
C     false and amax is set to the biggest positive scalar such that
C     x + amax*d is inside the box.

      call compamax(nind,x,l,u,d,amax,rbdnnz,rbdind,rbdtype)
      
C     ==================================================================
C     Point on the boundary
C     ==================================================================      
      
C     If xtrial is not interior to the box, xtrial = x + d is replaced
C     by xtrial = x + amax*d. Now xtrial is definitely interior. Actually,
C     it is in the boundary. If the objective function decreases in
C     xtrial, the inner algorithm stops with xtrial as a solution.
C     Otherwise, a new trust-region radius trdelta is chosen (smaller than
C     dbound) and a new quadratic model minimizer is calculated (which
C     is necessarily interior because of the choice of trdelta).

      if ( amax .le. 1.0d0 ) then 
          
          if ( iprintinn .ge. 5 ) then
              write(*, 2010) 
              write(10,2010) 
          end if
          
          do i = 1,nind
              xtrial(i) = x(i) + amax * d(i)
          end do
          
          stpl = amax

C         Set x(i) to l(i) or u(i) for the indices i that got to the 
C         boundary (to prevent errors).
          
          do i = 1,rbdnnz
              index = rbdind(i)
              if ( rbdtype(i) .eq. 'L' ) then
                  xtrial(index) = l(index)
              elseif ( rbdtype(i) .eq. 'U' ) then
                  xtrial(index) = u(index)
              end if
          end do

          call csetp(nind,xtrial)

          call calcal(nind,xtrial,m,lambda,rho,equatn,linear,ftrial,
     +    inform)
          if ( inform .lt. 0 ) return
          
C         Print functional value

          if ( iprintinn .ge. 5 ) then
              write(*, 1030) trdelta,ftrial,fcnt
              write(10,1030) trdelta,ftrial,fcnt
          end if

C         Test whether f is very small
      
          if ( ftrial .le. fmin ) then
              
              call calcnal(nind,xtrial,m,lambda,rho,equatn,linear,
     +        gtrial,inform)
              if ( inform .lt. 0 ) return

              betinfo = 2
              
              if ( iprintinn .ge. 5 ) then
                  write(*, 9050) 
                  write(10,9050) 
              end if
              
              return
          end if      
          
C         If the new point x + d is too close to the previous point x, 
C         inner algorithm stops

          samep = .true.
          do i = 1,nind
              if ( xtrial(i) .gt. x(i) + 
     +             macheps * max( 1.0d0, abs( x(i) ) ) .or.
     +             xtrial(i) .lt. x(i) - 
     +             macheps * max( 1.0d0, abs( x(i) ) ) ) then
                  samep = .false.
              end if
          end do
          
          if ( samep .and. ftrial .le. f + macheps23 * abs(f) ) then
              
              betinfo = 3
              
              if ( iprintinn .ge. 5 ) then
                  write(*, 9060) 
                  write(10,9060) 
              end if
              
              return
          end if

C         Test if function value decreases at xtrial
        
          if ( ( ftrial .le. f ) .or. 
     +         ( ( deucn .le. macheps23 * xeucn ) .and.
     +         ( ftrial .le. f + macheps23 * abs( f ) ) ) ) then
              
              if ( iprintinn .ge. 5 ) then
                  write(*, 2030) 
                  write(10,2030) 
              end if
              
              if ( extrp4 ) then
                  
                  call extrapolation(nind,x,l,u,m,lambda,rho,equatn,
     +            linear,g,xtrial,ftrial,gtrial,d,stpl,amax,rbdnnz,
     +            rbdind,rbdtype,fmin,beta,etaext,maxextrap,extinfo,
     +            inform)

                  if ( inform .lt. 0 ) return

                  if ( extinfo .eq. 2 ) then
                      betinfo = 2
                  else
                      betinfo = 0
                  end if

C                 Update the trust-region radius (which may or may not
C                 be used)

                  if ( frstit ) then
                      trdelta = 2.0d0 * max( trdelta, stpl * deucn )
                  end if
                  
                  if ( betinfo .eq. 2 ) then
                      if ( iprintinn .ge. 5 ) then
                          write(*, 9050) 
                          write(10,9050) 
                      end if
                      
                      return
                  end if
                  
                  betinfo = 1
                  
C                 Calculate actual reduction of objective function

                  ared = f - ftrial

                  go to 200
                  
              else
                  
C                 Update the trust-region radius (which may or may not
C                 be used)
               
                  trdelta = 2.0d0 * trdelta
                  
C                 Calculate actual reduction of objective function

                  ared = f - ftrial
                  
C                 Compute gtrial.
                  
                  call calcnal(nind,xtrial,m,lambda,rho,equatn,linear,
     +            gtrial,inform)
                  if ( inform .lt. 0 ) return
                  
                  betinfo = 1
                  
                  go to 200
              end if
              
          else
              tmp      = trdelmin + msrho * 
     +                   ( ( dbound / (1.0d0 + mssig ) ) - trdelmin )
              newdelta = trdelta
              trdelta  = max( trdelmin, tmp )

              triter   = triter + 1
              frstit   = .false.

              if ( iprintinn .ge. 5 ) then
                  write(*, 2040) 
                  write(10,2040) 
              end if

              go to 100
          end if
      end if

C     ==================================================================
C     Point interior to the box
C     ==================================================================
      
C     step 5: in this case xtrial is inside the box. Acceptance or
C             rejection of the trust-region subproblem solution.

      call csetp(nind,xtrial)

      call calcal(nind,xtrial,m,lambda,rho,equatn,linear,ftrial,inform)
      if ( inform .lt. 0 ) return

C     Print functional value

      if ( iprintinn .ge. 5 ) then
          write(*, 1030) trdelta,ftrial,fcnt
          write(10,1030) trdelta,ftrial,fcnt
      end if

C     Test whether f is very small
      
      if ( ftrial .le. fmin ) then
          
          call calcnal(nind,xtrial,m,lambda,rho,equatn,linear,gtrial,
     +    inform)
          if ( inform .lt. 0 ) return

          betinfo = 2
          
          if ( iprintinn .ge. 5 ) then
              write(*, 9050) 
              write(10,9050) 
          end if
          
          return
      end if
      
C     If the new point x + d is too close to the previous point x, inner
C     algorithm stops

      samep = .true.
      do i = 1,nind
c         if ( abs( x(i) - xtrial(i) ) .gt. 
c    +         macheps * max( abs( xtrial(i) ), 1.0d0 ) ) then
          if ( xtrial(i) .gt. x(i) + macheps * max(1.0d0,abs(x(i))) .or.
     +         xtrial(i) .lt. x(i) - macheps * max(1.0d0,abs(x(i))) ) 
     +    then
              samep = .false.
          end if
      end do
      
c     if ( samep .and. ftrial - f .le. macheps23 * abs(f) ) then
      if ( samep .and. ftrial .le. f + macheps23 * abs(f) ) then
          
          betinfo = 3
          
          if ( iprintinn .ge. 5 ) then
              write(*, 9060) 
              write(10,9060) 
          end if
          
          return
      end if
      
C     Calculate actual reduction of objective function
      
      ared = f - ftrial
      
C     If there is not sufficient decrease of the function, the 
C     trust-region radius is decreased and the new quadratic model 
C     minimizer will be calculated. 

      if ( iprintinn .ge. 5 ) then
          write(*, 1010) deucn,pred,ared
          write(10,1010) deucn,pred,ared
      end if

      samep = .true.
      do i = 1,nind
          if ( xtrial(i) .gt. x(i)+macheps23*max(1.0d0,abs(x(i))) .or.
     +         xtrial(i) .lt. x(i)-macheps23*max(1.0d0,abs(x(i))) ) then
              samep = .false.
          end if
      end do

c     if ( deucn .le. macheps23 * xeucn .and.
c    +     ared  .le. macheps23 * abs( f ) ) then
         
c     if ( samep .and. ared .le. macheps23 * abs(f) ) then

      if ( samep .and. ftrial .ge. f - macheps23 * abs(f) ) then

          call calcnal(nind,xtrial,m,lambda,rho,equatn,linear,gtrial,
     +    inform)
          if ( inform .lt. 0 ) return
          
          go to 200

      end if
      
      if ( ( pred .le. phieps .or. ared .ge. tralpha*pred ) .and.
     +     ( pred .gt. phieps .or. f .ge. ftrial ) ) then

C         If extrapolation at step 5 is not to be performed, point 
C         xtrial is accepted.

          if ( extrp5 ) then
          
              call extrapolation(nind,x,l,u,m,lambda,rho,equatn,linear,
     +        g,xtrial,ftrial,gtrial,d,stpl,amax,rbdnnz,rbdind,rbdtype,
     +        fmin,beta,etaext,maxextrap,extinfo,inform)
              
              if ( inform .lt. 0 ) return
              
              if ( extinfo .eq. 2 ) then
                  betinfo = 2
              else
                  betinfo = 0
              end if
              
              if ( frstit ) then
                  trdelta = max( trdelta, stpl * deucn )
              end if
              
              if ( betinfo .eq. 2 ) then
                  if ( iprintinn .ge. 5 ) then
                      write(*, 9050) 
                      write(10,9050) 
                  end if
                  
                  return
              end if
              
C             Update actual reduction of objective function
              
              ared = f - ftrial
              
          else
              
              call calcnal(nind,xtrial,m,lambda,rho,equatn,linear,
     +        gtrial,inform)
              if ( inform .lt. 0 ) return
              
          end if

      else

          trdelta = 2.5d-1 * deucn
          triter  = triter + 1
          frstit  = .false.

          if ( iprintinn .ge. 5 ) then
              write(*, 2050) 
              write(10,2050) 
          end if
          
          go to 100

      end if
      
C     ==================================================================
C     Prepare for next call to this routine
C     ==================================================================
      
C     Update the trust-region radius (which may or may not be used). 
C     This update can only be done when the current iteration was a 
C     trust-region iteration (and not an inner SPG one).

 200  continue

      if ( ared .lt. 2.5d-1 * pred ) then
          trdelta = max( 2.5d-1 * deucn, trdelmin )
      else
          if ( ( ared .ge. 0.5d0 * pred ) .and.
     +         ( deucn .ge. trdelta - macheps23 * 
     +         max( trdelta, 1.0d0 ) ) ) then
              trdelta = max( 2.0d0 * trdelta, trdelmin )
          else
              trdelta = max( trdelta, trdelmin )
          end if
      end if
      
C     If new point x is in the boundary, the inner algorithm stops
C     and returns x as solution.

      if ( stpl .ge. amax ) then
          
          betinfo = 1
          
          if ( iprintinn .ge. 5 ) then
              write(*, 9030) 
              write(10,9030) 
          end if
          
      else
          
          betinfo = 0
          
          if ( iprintinn .ge. 5 ) then
              write(*, 9000) 
              write(10,9000) 
          end if
      end if
      
C     Non-executable statements
      
 1000 format(/,5X,'Trust-region iteration')
 1010 format(  5X,'deucn = ',1P,D7.1,' pred = ',1P,D11.4,
     +            ' ared = ',1P,D11.4)
 1020 format(/,5X,'Trust-region direction (first ',I7,
     +            ' components): ',/,1(5X,6(1X,1P,D11.4)))
 1030 format(/,5X,'delta = ',1P,D7.1,' F = ',1P,D24.16,' FE = ',I7)

 2000 format(/,5X,'Since the direction More-Sorensen calculation ',
     +       /,5X,'failed, dogleg direction will be computed.')
 2010 format(/,5X,'x+d is not interior to the box.')
 2030 format(  5X,'f(x+d) < f(x), x+d is accepted.')
 2040 format(  5X,'f(x+d) >= f(x), a new direction d will be computed.')
 2050 format(  5X,'x+d did not obtain suficcient functional reduction. '
     +       /,5X,'A new direction d will be computed.')
 2060 format(/,5X,'Direction is undefined. ',
     +            'A new direction d will be computed.')
 2070 format(/,5X,'Point close to the boundary. ',
     +            'An inner SPG iteration will be used.')

 9000 format(  5X,'Flag of TR: Sufficient decrease of function.')
 9010 format(  5X,'Flag of TR: ',
     +            'First-order stationary point close to boundary.')
 9020 format(/,5X,'Flag of TR: Second-order stationary point.')
 9030 format(  5X,'Flag of TR: Point on the boundary.')      
 9040 format(  5X,'Flag of TR: Trust-region radius too small.')
 9050 format(  5X,'Flag of TR: Unbounded objective function?')
 9060 format(  5X,'Flag of TR: Very similar consecutive points.')
 9070 format(  5X,'Flag of TR: Undefined direction.')

      end

C     ******************************************************************
C     ******************************************************************

      subroutine squad(nred,x,g,hnnz,hlin,hcol,hval,phi)

      implicit none

C     SCALAR ARGUMENTS
      integer hnnz,nred
      double precision phi
      
C     ARRAY ARGUMENTS
      integer hcol(hnnz),hlin(hnnz)
      double precision g(nred),hval(hnnz),x(nred)

C     Evaluates the quadratic model phi(x) = 1/2 x^T H x + g^T x.

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )

C     LOCAL SCALARS
      integer col,i,lin
      
C     LOCAL ARRAYS
      double precision wd(nmax)

      do i = 1,nred
          wd(i) = 0.0d0
      end do
      
      do i = 1,hnnz
          lin = hlin(i)
          col = hcol(i)
          
          wd(lin) = wd(lin) + hval(i) * x(col)
          if ( lin .ne. col ) then
              wd(col) = wd(col) + hval(i) * x(lin)
          end if
      end do
      
      phi = 0.0d0
      do i = 1,nred
          phi = phi + wd(i) * x(i)
      end do
      
      phi = phi * 0.5d0
      
      do i = 1,nred
          phi = phi + g(i) * x(i)
      end do
      
      end      
      
C     *****************************************************************
C     *****************************************************************

C     Algorithm that finds a unconstrained minimizer of objective 
C     function inside the box of constraints, hits the boundary 
C     (obtaining function decrease), or finds an interior point where 
C     the objective function has sufficient decrease (compared to its 
C     value at x). Extrapolation may be done.
C
C     When the current point x is "close to" the boundary, a Spectral 
C     Projected Gradient (SPG) iteration is used to calculate the new 
C     point. If this new point is at the boundary, the algorithm stops. 
C     Otherwise, a new iteration begins.
C
C     When x is "far from" the boundary, trust-region radius is 
C     determined and d is calculated using More-Sorensen algorithm to 
C     solve the trust-region subproblem (which is to find a minimizer a 
C     to a function quadratic model provided that the minimizer's 
C     Euclidian-norm is smaller than a given delta). The new point is
C     xtrial = x + d. 
C
C     If xtrial lies outside the box of constraints, it is truncated on 
C     the boundary. This new y on the boundary will be candidate to be a 
C     solution. If function value at new xtrial is smaller than function 
C     value at x, inner algorithm stops with xtrial. Otherwise, the 
C     trust-region radius is decreased so that the new solution d' to 
C     the trust-region subproblem makes x + d' be interior to the box.
C     More-Sorensen algorithm is used to calculate d' too.
C
C     If xtrial lies inside the box, sufficient decrease of objective 
C     function is tested. If it is true, xtrial is accepted as a solution
C     candidate. If xtrial in on the boundary, inner algorithm stops and 
C     if it is interior, a new iteration begins. If sufficient decrease is 
C     not obtained, trust-region radius is decreased and a new quadratic 
C     model minimizer is calculated (as in a classical trust-region 
C     algorithm for unconstrained minimization).
C
C     If the user wants, after calculating the candidate solution xtrial, 
C     extrapolation may be performed. For this, set extrpi to true, 
C     where i is the step of the inner algorithm that can call 
C     extrapolation procedure. If extrp4 is true, extrapolation will be
C     tried after xtrial hit the boundary. And if extrp5 is true,
C     extrapolation will be tried after xtrial is calculated by
C     trust-region algorithm, when xtrial is interior and provides
C     sufficient decrease of objective function.
C
C     If gradient at current point is null, inner algorithm stops 
C     declaring "first-order stationary point". If quadratic model 
C     minimum is 0, inner algorithm stops declaring "second-order 
C     stationary point".
C
C     M. Andretta, E. G. Birgin and J. M. Martinez, ''Practical active-set
C     Euclidian trust-region method with spectral projected gradients for
C     bound-constrained minimization'', Optimization 54, pp. 305-325, 2005.
C
C     On Entry
C      
C     n        integer
C              dimension of full space
C
C     nind     integer
C              dimension of reduced space
C
C     x        double precision x(n)
C              initial point, interior to the current face
C
C     l        double precision l(n)
C              lower bounds on x
C
C     u        double precision u(n)
C              upper bounds on x
C
C     m        integer
C     lambda   double precision lambda(m)
C     rho      double precision rho(m)
C     equatn   logical equatn(m)
C     linear   logical linear(m)
C              These five parameters are not used nor modified by 
C              BETRA and they are passed as arguments to the user-
C              defined subroutines evalal and evalnal to compute the 
C              objective function and its gradient, respectively. 
C              Clearly, in an Augmented Lagrangian context, if BETRA is 
C              being used to solve the bound-constrained subproblems, m 
C              would be the number of constraints, lambda the Lagrange 
C              multipliers approximation and rho the penalty parameters.
C              equatn is logical array that, for each constraint, 
C              indicates whether the constraint is an equality constraint
C              (.true.) or an inequality constraint (.false.). Finally,
C              linear is logical array that, for each constraint, 
C              indicates whether the constraint is a linear constraint
C              (.true.) or a nonlinear constraint (.false.)
C
C     f        double precision
C              objective function value at x
C
C     g        double precision g(n)
C              gradient at x
C
C     trdelta  double precision 
C              trust-region radius
C
C     newdelta double precision
C              trust-region radius is set to the maximum between newdelta 
C              and trdelta
C     
C     mslamb   double precision
C              value that More-Sorensen algorithm calculates to find 
C              the trust-region subproblem solution (MEQB)
C
C     epsg     double precision
C              allowed error for projected gradient norm
C
C     xeucn    double precision
C              x Euclidian norm
C
C     xsupn    double precision
C              x sup-norm
C
C     gpeucn   double precision
C              projected-gradient Euclidian norm
C
C     On Return
C      
C     trdelta  double precision
C              updated trut-region radius
C
C     newdelta double precision
C              when the trust-region radius trdelta is decreased so that 
C              the point x + d fit the current face, newdelta is set to 
C              the previous value of trdelta. Otherwise, it is set to 0
C
C     mslamb   double precision
C              updated value for next iteration (see entry parameter)
C
C     d        double precision d(nind)
C              direction computed such that xtrial = x + d
C
C     rbdind   integer rbdind(n)
C              indices of variables that reached their bounds
C     
C     rbdtype  character rbdtype(n)
C              if variable rbdind(i) reached its lower bound, 
C              rbdtype(i) = 'L'. If variable rbdind(i) reached its upper
C              bound, rbdtype(i) = 'U'. 
C
C     xtrial   double precision xtrial(n)
C              solution candidate, with inform as described bellow
C
C     ftrial   double precision
C              objective function value at xtrial
C
C     gtrial   double precision gtrial(n)
C              gradient at xtrial
C
C     triter   integer
C              number of trust-region iterations
C
C     chcnt    integer
C              number of Cholesky decompositions
C
C     memfail  logical
C              true iff linear solver failed because of lack of memory
C
C     betinfo  integer
C              This output parameter tells what happened in this 
C              subroutine, according to the following conventions:
C      
C              0 = Sufficient decrease of the function;
C
C              1 = x hits the boundary;
C
C              2 = Unbounded objective function?
C
C              3 = Either the search direction or the step lenght is too
C                  small;
C
C              4 = Trust-region radius too small;
C
C              5 = Undefined direction;
C
C              6 = x is a first-order stationary point close to the
C                  boundary;
C
C              7 = x is a second-order stationary point;
C
C     inform   0 = no error occurred;
C             <0 = error in some function, gradient or Hessian routine.
C     ******************************************************************
C     ******************************************************************

      subroutine dogleg(n,g,hnnz,hlin,hcol,hval,pd,delta,p,dlinfo)

      implicit none

C     SCALAR ARGUMENTS
      logical pd
      integer dlinfo,hnnz,n
      double precision delta

C     ARRAY ARGUMENTS
      integer hcol(hnnz),hlin(hnnz)
      double precision g(n),hval(hnnz),p(n)

C     Compute approximate minimizer of the quadratic model using Dogleg
C     method when the Hessian is positive definite and Cauchy point
C     otherwise.

C     dlinfo:
C
C     0: successfull exit. Both H and g are null;
C     1: successfull exit.

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      double precision bignum,macheps,macheps12,macheps13,macheps23

C     COMMON BLOCKS
      common /machcon/ bignum,macheps,macheps12,macheps13,macheps23
      save   /machcon/
C     COMMON SCALARS
      logical iprintctl(7)
      integer iprintinn,iprintout,mprint,nprint

C     COMMON BLOCKS
      common /outdat/ iprintctl,iprintinn,iprintout,nprint,mprint
      save   /outdat/


C     LOCAL SCALARS
      integer col,i,lin
      double precision a,b,c,coef,d,delta2,geucn,geucn2,gthg,pbeucn2,
     +        pueucn,pueucn2,putpb,r

C     LOCAL ARRAYS
      double precision pu(nmax)
C     Presentation

      if ( iprintinn .ge. 5 ) then
          write(* ,1000)
          write(10,1000)
      end if

C     Initialization

      dlinfo = 1
      delta2 = delta**2

C     If H is not positive definite, compute Cauchy point

      if ( .not. pd ) then
          go to 100
      end if

      pbeucn2 = 0.0d0
      do i = 1,n
          pbeucn2 = pbeucn2 + p(i)**2
      end do

C     If Newton step is inside the trust region, this step is taken

      if ( pbeucn2 .le. delta2 ) then
          go to 500
      end if

C     If Newton step is outside the trust region, compute the
C     unconstrained minimizer pu of the quadratic function

C     Compute g^T H g

      do i = 1,n
          pu(i) = 0.0d0
      end do

      do i = 1,hnnz
          lin = hlin(i)
          col = hcol(i)

          pu(lin) = pu(lin) + hval(i) * g(col)
          if ( lin .ne. col ) then
              pu(col) = pu(col) + hval(i) * g(lin)
          end if
      end do

      gthg = 0.0d0
      do i = 1,n
          gthg = gthg + g(i) * pu(i)
      end do

C     Compute g^T g.

      geucn2 = 0.0d0
      do i = 1,n
          geucn2 = geucn2 + g(i)**2
      end do

C     Compute pu = coef * g.

      coef = - geucn2 / gthg
      do i = 1,n
          pu(i) = coef * g(i)
      end do

C     If uncontrained minimizer is outside the trust region, it is
C     truncated at the border

      pueucn2 = 0.0d0
      do i = 1,n
          pueucn2 = pueucn2 + pu(i)**2
      end do
      pueucn = sqrt( pueucn2 )

      if ( pueucn2 .ge. delta2 ) then
          r = delta / pueucn
          do i = 1,n
              p(i) = r * pu(i)
          end do
          go to 500
      end if

C     Compute step length in directions pu and pb. Direction p is a
C     linear combination of pu and pb. To compute the step length in
C     each direction, we have to solve (in r):
C     \| pu + (r - 1) (pb - pu) \|^2 = delta^2.

      putpb = 0.0d0
      do i = 1,n
          putpb = putpb + pu(i) * p(i)
      end do

      a = pbeucn2 + pueucn2 - 2.0d0 * putpb
      b = - 2.0d0 * pbeucn2 - 4.0d0 * pueucn2 + 6.0d0 * putpb
      c = pbeucn2 + 4.0d0 * pueucn2 - 4.0d0 * putpb - (delta**2)
      d = b**2 - 4.0d0 * a * c

      if ( ( 2.0d0 * abs( a ) .lt. macheps23 ) .or.
     +     ( d .lt. 0.0d0 ) ) then
          go to 200
      end if

      r = (- b + sqrt( d )) / (2.0d0 * a)

      if ( ( r .lt. 1.0d0 ) .or. ( r .gt. 2.0d0 ) ) then
          r = (- b - sqrt( d )) / (2.0d0 * a)
      end if
      r = r - 1.0d0

      do i = 1,n
          p(i) = r * p(i) + (1.0d0 - r) * pu(i)
      end do

      go to 500

C     Compute Cauchy point, when H is not positive definite

 100  continue

C     Compute g^T H g

      do i = 1,n
          pu(i) = 0.0d0
      end do

      do i = 1,hnnz
          lin = hlin(i)
          col = hcol(i)

          pu(lin) = pu(lin) + hval(i) * g(col)
          if ( lin .ne. col ) then
              pu(col) = pu(col) + hval(i) * g(lin)
          end if
      end do

      gthg = 0.0d0
      do i = 1,n
          gthg = gthg + g(i) * pu(i)
      end do

C     Compute g^T g

      geucn2 = 0.0d0
      do i = 1,n
          geucn2 = geucn2 + g(i)**2
      end do
      geucn = sqrt( geucn2 )

C     Compute step length coef

 200  if ( ( abs( gthg ) .le. macheps23 ) .and.
     +     ( geucn .le. macheps23 ) ) then

          dlinfo = 0

          if ( iprintinn .ge. 5 ) then
              write(* ,1020)
              write(10,1020)
          end if

          return
      end if

      if ( ( gthg .le. 0.0d0 ) .or.
     +     ( geucn2*geucn .lt. delta*gthg ) ) then
          coef = - delta / geucn
      else
          coef = - geucn2 / gthg
      end if

C     Compute p = coef * g

      do i = 1,n
          p(i) = coef * g(i)
      end do

C     Termination

 500  continue

      if ( iprintinn .ge. 5 ) then
          write(* ,1010)
          write(10,1010)
      end if

      if ( iprintinn .ge. 5 .and. nprint .ne. 0 ) then
          write(*, 1030) min0(n,nprint),(p(i),i=1,min0(n,nprint))
          write(10,1030) min0(n,nprint),(p(i),i=1,min0(n,nprint))
      end if

 1000 format(/,5X,'Computation of Dogleg direction.')
 1010 format(  5X,'Dogleg computed successfully.')
 1020 format(  5X,'Null direction was computed.')
 1030 format(/,5X,'Dogleg direction (first ',I7,' components): ',
     +       /,1(5X,6(1X,1P,D11.4)))

      end

C     ******************************************************************
C     ******************************************************************

C     Compute approximate minimizer of the quadratic model using Dogleg
C     method when the Hessian is positive definite and Cauchy point
C     otherwise.

C     On Entry
C
C     n        integer
C              dimension
C
C     g        double precision g(n)
C              vector used to define the quadratic function
C
C     hnnz     integer
C              number of nonzero elements of H
C
C     hlin     integer hlin(hnnz)
C              row indices of nonzero elements of H
C
C     hcol     integer hcol(hnnz)
C              column indices of nonzero elements of H
C
C     hval     double precision hval(hnnz)
C              nonzero elements of H, that is,
C              H(hlin(i),hcol(i)) = hval(i). Since H is symmetric, just
C              one element H(i,j) or H(j,i) must appear in its sparse
C              representation. If more than one pair corresponding to
C              the same position of H appears in the sparse
C              representation, the multiple entries will be summed.
C              If any hlin(i) or hcol(i) is out of range, the entry will
C              be ignored
C
C     pd       logical
C              indicates if the last Cholesky decomposition of moresor
C              was successfull. That is, if the last matrix used by
C              moresor was positive definite
C
C     delta    double precision
C              trust-region radius
C
C     On Return
C
C     p        double precision p(n)
C              solution to problem
C              minimize     psi(w)
C              subjected to ||w|| <= delta
C
C     dlinfo   integer
C              This output parameter tells what happened in this
C              subroutine, according to the following conventions:
C
C              0 = successfull exit. Both H and g are null;
C
C              1 = successfull exit.
C     ******************************************************************
C     ******************************************************************

      subroutine moresor(n,g,bnnz,blin,bcol,bval,bdiag,delta,sigma1,
     +sigma2,eps,maxit,l,pd,p,chcnt,memfail,msinfo)

      implicit none

C     SCALAR ARGUMENTS
      logical memfail,pd
      integer bnnz,chcnt,maxit,msinfo,n
      double precision delta,eps,l,sigma1,sigma2

C     ARRAY ARGUMENTS
      integer bcol(bnnz),bdiag(n),blin(bnnz)
      double precision bval(bnnz),g(n),p(n)

C     Solves the problem
C
C     minimize    psi(w) = 1/2 w^TBw + g^Tw
C     subject to  ||w|| <= delta
C
C     Using the method described in "Computing a trust region step",
C     by More and Sorensen.

C     msinfo:
C
C     0: both g and B are null
C     1: first convergence criterion is satisfied
C     2: second convergence criterion is satisfied
C     3: third convergence criterion is satisfied
C     5: maximum allowed number of iterations is achieved

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      double precision bignum,macheps,macheps12,macheps13,macheps23

C     COMMON BLOCKS
      common /machcon/ bignum,macheps,macheps12,macheps13,macheps23
      save   /machcon/
C     COMMON SCALARS
      logical iprintctl(7)
      integer iprintinn,iprintout,mprint,nprint

C     COMMON BLOCKS
      common /outdat/ iprintctl,iprintinn,iprintout,nprint,mprint
      save   /outdat/


C     LOCAL SCALARS
      integer col,dum,i,idx,iter,lin,lssinfo
      double precision b1n,d,delta2,geucn,ll,llant,ls,lsant,lu,luant,
     +        peucn,peucn2,ptz,rpeucn2,rzeucn2,sgn,tau,teucn2,tmp,ueucn2

C     LOCAL ARRAYS
      integer wi(nmax)
      double precision t(nmax),wd(nmax),z(nmax)

      delta2 = delta**2

      msinfo  = 0

      memfail = .false.

      call lssini(.false.,.false.,.true.)

C     step 1: initialize ls (lower bound on l) with max{-bii}, where bii
C     are the elements of the diagonal of B

      ls = -bval(bdiag(1))

      do i = 2,n
          lin = bdiag(i)
          ls  = max( ls, -bval(lin) )
      end do

C     Calculate ||B||1, B sparse

      do i = 1,n
          wd(i) = 0.0d0
      end do

      do i = 1,bnnz
          lin = blin(i)
          col = bcol(i)

          if ( ( lin .le. n ) .and. ( col .le. n ) ) then
              wd(col) = wd(col) + abs( bval(i) )
              if ( lin .ne. col ) then
                  wd(lin) = wd(lin) + abs( bval(i) )
              end if
          end if
      end do

      b1n = wd(1)
      do i = 2,n
          b1n = max( b1n, wd(i) )
      end do

C     step 2: initialize ll (lower bound on l) with
C             max{0, ls, ||g||/delta - ||B||1}, where ||B||1 is the
C             1-norm of the matrix B

      geucn = 0.0d0
      do i = 1,n
          geucn = geucn + g(i)**2
      end do
      geucn = sqrt( geucn )

      ll = (geucn / delta) - b1n
      ll = max( 0.0d0, ll )
      ll = max( ls, ll )

C     step 3: initialize lu (upper bound on l) with ||g||/delta + ||B||1

      lu = (geucn / delta) + b1n

C     If the matrix is null, there is nothing to be done

      if ( ( abs( ll ) .le. macheps23 ) .and.
     +     ( abs( lu ) .le. macheps23 ) .and.
     +     ( abs( ls ) .le. macheps23 ) ) then
          msinfo = 0
          go to 21
      end if

C     step 4: initialize iteration counter

      iter = 1

      call lssana(n,bnnz,blin,bcol,bval,bdiag,lssinfo)

      if ( lssinfo .eq. 6 ) then
        ! INSUFFICIENT SPACE TO STORE THE LINEAR SYSTEM

          memfail = .true.
          return

      else if ( lssinfo .eq. 7 ) then
        ! INSUFFICIENT DOUBLE PRECISION WORKING SPACE

          memfail = .true.
          return

      else if ( lssinfo .eq. 8 ) then
        ! INSUFFICIENT INTEGER WORKING SPACE

          memfail = .true.
          return

      end if

C     step 5: safeguard of l (ensures that l is bigger than ll)

 5    continue

      l = max( l, ll )

C     step 6: safeguard of l (ensures that l is smaller than lu)

      l = min( l, lu )

C     step 7: safeguard of l

      if ( ( l .le. ls + macheps23 * max( abs( ls ), 1.0d0 ) )
     +     .and. ( iter .ne. 1 ) ) then
          l = max( 1.0d-3 * lu, sqrt( ll*lu ) )
      end if

C     step 8: try to use the Cholesky decomposition: (B +lI) = R^TR.
C             If the decomposition is successfull, R is stored in the
C             upper triangular portion of B (including the diagonal) and
C             pd is set to true.
C             If the decomposition fails, d and idx are set as explained
C             before, pd is set to false, and the Euclidian-norm of u is
C             calculated (see explanation of variable ueucn2)

      do i = 1,n
          wd(i) = l
      end do

      call lssfac(n,bnnz,blin,bcol,bval,bdiag,wd,idx,d,dum,lssinfo)
      chcnt = chcnt + 1

      if ( lssinfo .eq. 6 ) then
        ! INSUFFICIENT SPACE TO STORE THE LINEAR SYSTEM

          memfail = .true.
          return

      else if ( lssinfo .eq. 7 ) then
        ! INSUFFICIENT DOUBLE PRECISION WORKING SPACE

          memfail = .true.
          return

      else if ( lssinfo .eq. 8 ) then
        ! INSUFFICIENT INTEGER WORKING SPACE

          memfail = .true.
          return

      end if

      if ( ( lssinfo .eq. 1 ) .or. ( lssinfo .eq. 2 ) ) then
          pd = .false.
      else ! lssinfo .eq. 0
          pd = .true.
      end if

C     In this case (B + lI) is not positive definite, and d and idx are
C     calculated. Because p cannot be calculated (it is not possible to
C     solve the system using Cholesky factorization), the values of l,
C     ll and ls are updated, the iteration counter is increased and a
C     new iteration is started

      if ( .not. pd ) then

C         Print information (current iteration)

          if ( iprintinn .ge. 5 ) then
              write(*, 1000) iter
              write(*, 1010) ls,ll,lu,l
              write(*, 1070)

              write(10,1000) iter
              write(10,1010) ls,ll,lu,l
              write(10,1070)
          end if

          llant = ll
          luant = lu
          lsant = ls

          if ( lu-l .le. macheps23 * max( abs( lu ),1.0d0 ) ) then
              lu = lu + macheps23 * max( abs( lu ),1.0d0 )
              l  = lu
          else
              call scalcu(n,bnnz,blin,bcol,bval,bdiag,l,idx,p,ueucn2,wd,
     +        memfail)
              chcnt = chcnt + 1

              if ( memfail ) then
                  go to 22
              end if

              ll = max( l, ll )
              ls = max( l + (d / ueucn2), ls )
              ll = max( ll, ls )
              l  = ls
          end if

          iter = iter + 1

C         Test whether the number of iterations is exhausted

          if ( iter .gt. maxit ) then
              msinfo = 5

              if ( iprintinn .ge. 5 ) then
                  write(*, 1090)
                  write(10,1090)
              end if

              go to 22
          end if

          go to 5
      end if

C     step 9: solve R^TRp = -g for p and calculate the squared
C             Euclidian-norm of p

      do i = 1,n
          p(i) = -g(i)
      end do

      call lsssol(n,p)

C     Euclidian-norm of Rp = p^T R^TRp = p^T (-g) = - p^Tg

      rpeucn2 = 0.0d0
      do i = 1,n
          rpeucn2 = rpeucn2 - p(i) * g(i)
      end do

      peucn2 = 0.0d0
      do i = 1,n
          peucn2 = peucn2 + p(i)**2
      end do
      peucn = sqrt( peucn2 )

C     step 10: calculate z and tau, where tau * z is the approximation
C              of the eigenvector associated with the smallest
C              eigenvalue of B

      if ( peucn .lt. delta ) then

C        Calculate z

          call scalcz(n,wi,wd,z)

C         Calculate z Euclidian-norm

          tmp = 0.0d0
          do i = 1,n
              tmp = tmp + z(i)**2
          end do
          tmp = sqrt( tmp )

C         Divide z by its norm

          do i = 1,n
              z(i) = z(i) / tmp
          end do

C         Calculate the squared Euclidian-norm of the product Rz.
C         Note that z^T R^T Rz = z^T (B + lI) z

          do i = 1,n
              wd(i) = 0.0d0
          end do

          do i = 1,bnnz
              lin = blin(i)
              col = bcol(i)

              if ( lin .eq. col ) then
                  wd(lin) = wd(lin) + (bval(i) + l) * z(col)
              else
                  wd(lin) = wd(lin) + bval(i) * z(col)
                  wd(col) = wd(col) + bval(i) * z(lin)
              end if
          end do

          rzeucn2 = 0.0d0
          do i = 1,n
              rzeucn2 = rzeucn2 + z(i) * wd(i)
          end do

C         Calculate tau

          ptz = 0.0d0
          do i = 1,n
              ptz = ptz + p(i) * z(i)
          end do

          if ( ptz .lt. 0.0d0 ) then
              sgn = -1.0d0
          else
              sgn =  1.0d0
          end if

          tmp = delta2 - peucn2

          tau = (ptz**2) + tmp
          tau = tmp / (ptz + sgn * sqrt( tau ))

      end if

C     Print informations (current iteration)

      if ( iprintinn .ge. 5 ) then
          write(*, 1000) iter
          write(*, 1010) ls,ll,lu,l
          write(*, 1020) peucn

          write(10,1000) iter
          write(10,1010) ls,ll,lu,l
          write(10,1020) peucn

          if ( peucn .lt. delta ) then
              write(*, 1030) sqrt( peucn2 + 2 * tau * ptz + tau ** 2 )
              write(10,1030) sqrt( peucn2 + 2 * tau * ptz + tau ** 2 )
          else
              write(*, 1030) peucn
              write(10,1030) peucn
          end if

          write(*, 1050) delta
          write(10,1050) delta
      end if

C     steps 11 and 12: update ll, lu and ls

      llant = ll
      luant = lu
      lsant = ls

      if ( peucn .lt. delta ) then
          lu = min( l, lu )
          ls = max( l - rzeucn2, ls )
      else
          ll = max( l, ll )
      end if

C     step 13: update ls when B + lI is not positive definite.
C              This was done right after the Cholesky decomposition
C              failure

C     step 14: update ll

      ll = max( ll, ls )

C     step 15: convergence test

      if ( ( abs( l ) .le. eps ) .and. ( peucn .le. delta ) ) then
          msinfo = 1
          go to 21
      end if

C     step 16: second convergence test

      if ( abs( delta - peucn ) .le. sigma1*delta ) then
          msinfo = 2
      end if

C     step 17: convergence test for the hard case

      tmp = rpeucn2 + l * delta2
      tmp = max( sigma2, tmp )
      tmp = tmp * sigma1 * (2 - sigma1)

      if ( ( peucn .lt. delta ) .and. ( (rzeucn2*(tau**2) .le. tmp )
     +     .or. (lu - ll .le. eps) ) ) then

          msinfo = msinfo + 3
          go to 20
      end if

      if ( msinfo .eq. 2 ) then
          go to 21
      end if

C     step 21: Calculate l to be used in the next iteration

      if ( ( abs( geucn ) .gt. eps ) .or.
     +     ( ( l .le. ll + macheps23 * max( abs( ll ), 1.0d0 ) )
     +     .and. ( ls .le. ll ) ) ) then

C         Solve R^T t = p for t and calculate t squared Euclidian-norm

          do i = 1,n
              t(i) = p(i)
          end do

          call lsssoltr('T',n,t)

          teucn2 = 0.0d0
          do i = 1,n
              teucn2 = teucn2 + t(i)**2
          end do

C         Update l using Newton's method update

          l = l + (peucn2 / teucn2) * ((peucn - delta) / delta)
      else
          l = ls
      end if

C     step 22: update iteration counter

      iter = iter + 1

C     Test whether the number of iterations is exhausted

      if ( iter .gt. maxit ) then
          msinfo = 5

          if ( iprintinn .ge. 5 ) then
              write(*, 1090)
              write(10,1090)
          end if

          go to 22
      end if

C     step 23: start a new iteration

      if ( ( abs( llant-ll ) .le.
     +     macheps23 * max( abs( ll ), 1.0d0 ) ) .and.
     +     ( abs( luant-lu ) .le.
     +     macheps23 * max( abs( lu ), 1.0d0 ) ) .and.
     +     ( abs( lsant-ls ) .le.
     +     macheps23 * max( abs( ls ), 1.0d0 ) ) ) then

          ll = ll + macheps23 * max( abs( ll ), 1.0d0 )
          lu = lu - macheps23 * max( abs( lu ), 1.0d0 )
      end if

      go to 5

C     steps 18, 19 and 20:

C     The solution is given by p in 3 cases:
C     - if the first convergence criterion is satisfied;
C     - if only the second convergence criterion is satisfied;
C     - if both the second and the third convergence criteria are
C       satisfied, but the squared Euclidian-norm of R(tau*z) is
C       strictly bigger than l*(delta2 - peucn2)

C     The solution is given by p + tau*z when:
C     - just the third convergence criterion is satisfied;
C     - both the second and the third convergence criteria are
C       satisfied, but the squared Euclidian-norm of R(tau*z) is smaller
C       or equal to l*(delta2 - peucn2)

 20   tmp = (rzeucn2 * (tau**2)) - l * (delta2 - peucn2)

      if ( ( msinfo .eq. 3 ) .or.
     +     ( ( msinfo .eq. 5 ) .and. ( tmp .le. 0.0d0 ) ) ) then

          peucn2 = 0.0d0
          do i = 1,n
              p(i) = p(i) + tau * z(i)
              peucn2 = peucn2 + p(i)**2
          end do
          peucn = sqrt( peucn2 )

          msinfo = 3
      else
          msinfo = 2
      end if

C     Print informations

 21   if ( iprintinn .ge. 5 ) then
          write(*, 1060) iter
          write(*, 1010) ls,ll,lu,l
          write(*, 1080)
          write(*, 1040) peucn

          write(10,1060) iter
          write(10,1010) ls,ll,lu,l
          write(10,1080)
          write(10,1040) peucn
      end if

 22   continue

C     Non-executable statements

 1000 format(/,10X,'More-Sorensen iteration: ',I7)
 1010 format(  10X,'ls = ',1P,D11.4,
     +         10X,'ll = ',1P,D11.4,
     +         10X,'lu = ',1P,D11.4,
     +         10X,'l  = ',1P,D11.4)
 1020 format(  10X,'Euclidian-norm of p: ',1P,D7.1)
 1030 format(  10X,'Euclidian-norm of p + z: ',1P,D7.1)
 1040 format(  10X,'Euclidian-norm of step: ',1P,D7.1)
 1050 format(  10X,'delta: ',1P,D7.1)
 1060 format(  10X,'Number of iterations: ',I7)
 1070 format(  10X,'Matrix is not positive definite!')

 1080 format(  10X,'Flag of More-Sorensen: ',
     +             'convergence criterion satisfied.')
 1090 format(  10X,'Flag of More-Sorensen: ',
     +             'maximum number of iterations achieved.')

      end

C     ******************************************************************
C     ******************************************************************

      subroutine scalcu(n,annz,alin,acol,aval,adiag,l,idx,u,ueucn2,wd,
     +memfail)

      implicit none

C     SCALAR ARGUMENTS
      logical memfail
      integer annz,idx,n
      double precision l,ueucn2

C     ARRAY ARGUMENTS
      integer acol(annz),adiag(n),alin(annz)
      double precision aval(annz),u(idx),wd(idx-1)

C     Solves a sparse linear system of the form (A + lI + ekek^Td)u = 0,
C     where A + lI is a definite positive matrix in R^{k x k}.
C     u is a vector of k positions with u(k) = 1.

C     LOCAL SCALARS
      integer col,i,lin,lssinfo

      if ( idx .eq. 1 ) then
          u(idx) = 1.0d0
          ueucn2 = 1.0d0
          return
      end if

      do i = 1,idx
          u(i) = 0.0d0
      end do

C     Permute columns and rows of A

      call lsspermind(annz,alin,acol)

C     Eliminate columns that have index greater than idx and define u
C     as idx-th column of A + lI

      do i = 1,annz
          col = acol(i)
          lin = alin(i)

          if ( ( col .eq. idx ) .and. ( lin .lt. idx ) ) then
              u(lin) = u(lin) - aval(i)
          else if ( ( lin .eq. idx ) .and. ( col .lt. idx ) ) then
              u(col) = u(col) - aval(i)
          end if

          if ( ( col .ge. idx ) .or. ( lin .ge. idx ) ) then
              acol(i) = col + n
              alin(i) = lin + n
          end if
      end do

C     Solve system (A + lI)x = u

      call lssini(.false.,.true.,.false.)

      call lsspermvec(n,adiag)

      do i = 1,idx-1
          wd(i) = l
      end do

      call lssafsol(idx-1,annz,alin,acol,aval,adiag,wd,u,lssinfo)

      if ( lssinfo .eq. 6 ) then
        ! INSUFFICIENT SPACE TO STORE THE LINEAR SYSTEM

          memfail = .true.
          return

      else if ( lssinfo .eq. 7 ) then
        ! INSUFFICIENT DOUBLE PRECISION WORKING SPACE

          memfail = .true.
          return

      else if ( lssinfo .eq. 8 ) then
        ! INSUFFICIENT INTEGER WORKING SPACE

          memfail = .true.
          return

      end if

      call lssunpermvec(n,adiag)

      call lssini(.false.,.false.,.true.)

C     Undo modifications in acol and alin

      do i = 1,annz
          col = acol(i)

          if ( col .gt. n ) then
              acol(i) = acol(i) - n
              alin(i) = alin(i) - n
          end if
      end do

      call lssunpermind(n,annz,alin,acol)

      u(idx) = 1.0d0

      ueucn2 = 0.0d0
      do i = 1,idx
          ueucn2 = ueucn2 + u(i)**2
      end do

      end

C     ******************************************************************
C     ******************************************************************

      subroutine scalcz(n,rowind,rowval,z)

      implicit none

C     SCALAR ARGUMENTS
      integer n

C     ARRAY ARGUMENTS
      integer rowind(n)
      double precision rowval(n),z(n)

C     Sparse implementation of the technique presented by Cline, Moler,
C     Stewart and Wilkinson to estimate the condition number of a upper
C     triangular matrix.

C     COMMON SCALARS
      double precision bignum,macheps,macheps12,macheps13,macheps23

C     COMMON BLOCKS
      common /machcon/ bignum,macheps,macheps12,macheps13,macheps23
      save   /machcon/

C     LOCAL SCALARS
      integer col,i,k,rownnz
      double precision acs,acz,d,ek,rki,s,sm,w,wk,wkm
      double precision lssgetd

C     EXTERNAL FUNCTIONS
      external lssgetd

      call lsssetrow(n)

      do i = 1,n
          z(i) = 0.0d0
      end do

      acz = 0.0d0
      acs = 1.0d0
      ek  = 1.0d0

      do k = 1,n
          d = lssgetd(k)

          if ( abs( acs*z(k) ) .gt. macheps23 ) then
              ek = dsign(ek,-acs*z(k))
          end if

          if ( abs( ek - acs*z(k) ) .gt. abs( d ) ) then
              s   = abs( d ) / abs( ek - acs*z(k) )
              acs = acs * s
              ek  = s * ek
          end if

          wk  =  ek - acs * z(k)
          wkm = -ek - acs * z(k)
          s   = abs( wk )
          sm  = abs( wkm )

          if ( d .eq. 0.0d0 ) then
              wk  = 1.0d0
              wkm = 1.0d0
          else
              wk  = wk / d
              wkm = wkm / d
          end if

          if ( k .eq. n ) then
              go to 10
          end if

          call lssgetrow(n,k,rownnz,rowind,rowval)

          sm = sm + acs * acz

          do i = 1,rownnz

              col = rowind(i)
              if ( col .gt. k ) then
                  rki    = rowval(i)
                  sm     = sm - abs( acs * z(col) )
                  sm     = sm + abs( acs * z(col) + wkm * rki )
                  acz    = acz - abs( z(col) )
                  acz    = acz + abs( z(col) + (wk/acs) * rki )
                  z(col) = z(col) + (wk/acs) * rki
              end if
          end do

          s = s + acs * acz

          if ( s .lt.
     +         sm - macheps23 * max( abs( sm ), 1.0d0 ) ) then
              w = wkm - wk
              wk = wkm

              do i = 1,rownnz

                  col = rowind(i)
                  if ( col .gt. k ) then
                      rki    = rowval(i)
                      acz    = acz - abs( z(col) )
                      acz    = acz + abs( z(col) + (w/acs) * rki )
                      z(col) = z(col) + (w/acs) * rki
                  end if
              end do

          end if
          acz = acz - abs( z(k+1) )
 10       z(k) = wk/acs
      end do

C     Divide z by its 1-norm to avoid overflow

      s = 0.0d0
      do i = 1,n
          s = s + abs( z(i) )
      end do

      do i = 1,n
          z(i) = z(i) / s
      end do

C     Solve Rz = y

      call lsssoltr(' ',n,z)

      end

C     ******************************************************************
C     ******************************************************************

C     moresor:
C
C     Method to minimize sparse quadratic functions subjected to
C     ||w|| <= delta
C
C     minimize    psi(w) = 1/2 w^TBw + g^Tw
C     subject to  ||w|| <= delta
C
C     Method described in "Computing a trust region step", by More and
C     Sorensen.
C
C     The main ideia of this method is to find a positive scalar \mslamb
C     that is a zero of the function
C
C     phi(\mslamb) = 1/||p|| - 1/delta,
C
C     where p is the solution of the linear system
C
C     (B + \mslamb I)p = -g.
C
C     Note that symmetric matrix B, vector g and positive real number
C     delta are presented in the minimization problem above. I is the
C     identity matrix.
C
C     The method used to find the zero of that function is basically the
C     Newton method to find roots.
C
C     On Entry
C
C     n        integer
C              dimension
C
C     g        double precision g(n)
C              vector used to define the quadratic function
C
C     bnnz     integer
C              number of nonzero elements of B
C
C     blin     integer blin(bnnz)
C              row indices of nonzero elements of B
C
C     bcol     integer bcol(bnnz)
C              column indices of nonzero elements of B
C
C     bval     double precision bval(bnnz)
C              nonzero elements of B, that is,
C              B(blin(i),bcol(i)) = bval(i). Since B is symmetric, just
C              one element B(i,j) or B(j,i) must appear in its sparse
C              representation. If more than one pair corresponding to
C              the same position of B appears in the sparse
C              representation, the multiple entries will be summed.
C              If any blin(i) or bcol(i) is out of range, the entry will
C              be ignored
C
C     bdiag    integer bdiag(n)
C              indices of diagonal elements of B in blin, bcol and bval
C
C     delta    double precision
C              trust-region radius
C
C     sigma1   double precision
C              allowed error for convergence criteria 1 and 2
C
C     sigma2   double precision
C              allowed error for convergence criteria 3 (hard case)
C
C     eps      double precision
C              allowed error
C
C     maxit    integer
C              maximum number of allowed iterations
C
C     l        double precision
C              initial value for mslamb
C
C     On Return
C
C     l        double precision
C              value that gives p as a solution to the minimization
C              problem, because p is also solution to
C              (B + l I)p = -g
C
C     pd       logical
C              set to true if the last Cholesky decomposition is
C              successfull
C
C     p        double precision p(n)
C              solution to problem
C              minimize     psi(w)
C              subjected to ||w|| <= delta
C
C     chcnt    integer
C              number of Cholesky decompositions
C
C     memfail  logical
C              true iff linear solver failed because of lack of memory
C
C     msinfo   integer
C              stores which convergence criteria was satisfied:
C
C              0 = both g and B are null;
C
C              1 = first convergence criterion is satisfied;
C
C              2 = second convergence criterion is satisfied;
C
C              3 = third convergence criterion is satisfied
C
C              5 = maximum allowed number of iterations is achieved.

C     ******************************************************************
C     ******************************************************************

C     scalcu:
C
C     Solve a sparse linear system of the form (A + lI + ekek^Td)u = 0,
C     where A + lI is a definite positive matrix in R^{k x k}.
C     u is a vector of k positions with u(k) = 1.
C
C     On Entry
C
C     n        integer
C              dimension of A
C
C     annz     integer
C              number of nonzero elements of A
C
C     alin     integer alin(annz)
C              row indices of nonzero elements of A
C
C     acol     integer acol(annz)
C              column indices of nonzero elements of A
C
C     aval     integer aval(annz)
C              nonzero elements of A, that is,
C              A(alin(i),acol(i)) = aval(i). Since A is symmetric, just
C              one element A(i,j) or A(j,i) must appear in its sparse
C              representation. If more than one pair corresponding to
C              the same position of A appears in the sparse
C              representation, the multiple entries will be summed.
C              If any alin(i) or acol(i) is out of range, the entry will
C              be ignored
C
C     adiag    integer adiag(n)
C              indices of diagonal elements of A in alin, acol and aval
C
C     l        double precision
C              used to compute A + lI
C
C     idx      integer
C              index k
C
C     On Return
C
C     u        double precision u(n)
C              system solution
C
C     ueucn2   double precision
C              u squared Euclidian-norm
C
C     memfail  logical
C              true iff linear solver failed because of lack of memory

C     ******************************************************************
C     ******************************************************************

C     scalcz:
C
C     Sparse implementation of the technique presented by Cline, Moler,
C     Stewart and Wilkinson to estimate the condition number of a matrix.
C     This technique is used by the More-Sorensen method to calculate an
C     approximation to the eigenvector associated to the smallest
C     eigenvalue of a matrix B (\mslamb_1).
C     In this technique, when \mslamb approaches -\mslamb_1, \|Rz\|
C     approaches 0. This insures that z is an approximation to the
C     wanted eigenvector.
C     Basically, it solves R^Ty = e, choosing e(k) as 1 or -1 (whatever
C     gives maximum local growth of y). Then, it solves Rz = y.
C     Note that R is a sparse matrix given by P^T D^0.5 L^T P (obtained
C     applying subroutine MA27BD).
C
C     On Entry
C
C     n        integer
C              dimension of R
C
C     rowind   integer rowind(n)
C     rowval   double precision rowval(n)
C              working arrays
C
C     On Return
C
C     z        double precision z(n)
C              approximation of the eigenvector of B associated to
C              \mslamb_1
C     ******************************************************************
C     ******************************************************************

      subroutine spgls(n,x,l,u,m,lambda,rho,equatn,linear,f,g,lamspg,
     +xp,fp,alpha,d,evalaldim,setpdim,lsinfo,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,lsinfo,m,n
      double precision alpha,f,fp,lamspg

C     ARRAY ARGUMENTS
      logical equatn(m),linear(m)
      double precision d(n),g(n),l(n),lambda(m),rho(m),u(n),x(n),xp(n)

C     SUBROUTINE ARGUMENTS
      external evalaldim,setpdim

C     This subroutine computes a line search in the Spectral Projected
C     Gradient direction.
C
C     lsinfo:
C
C     0: Armijo satisfied
C     1: Small step with functional value similar to the current one
C     2: Unbounded objective function?
C     3: Too small backtracking step. Wrong gradient?

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical iprintctl(7)
      integer iprintinn,iprintout,mprint,nprint

C     COMMON BLOCKS
      common /outdat/ iprintctl,iprintinn,iprintout,nprint,mprint
      save   /outdat/

C     COMMON SCALARS
      integer efcnt,efccnt,egcnt,egjccnt,ehcnt,ehlcnt,ehlpcnt,fcnt

C     COMMON ARRAYS
      integer eccnt(mmax),ehccnt(mmax),ejccnt(mmax)

C     COMMON BLOCKS
      common /counters/ eccnt,ehccnt,ejccnt,efcnt,efccnt,egcnt,egjccnt,
     +                  ehcnt,ehlcnt,ehlpcnt,fcnt
      save   /counters/

C     LOCAL SCALARS
      integer i
      double precision dsupn,gtd,xsupn

C     ------------------------------------------------------------------
C     Compute search direction, directional derivative, dsupn, xsupn and
C     first trial
C     ------------------------------------------------------------------

      gtd   = 0.0d0
      dsupn = 0.0d0
      xsupn = 0.0d0
      do i = 1,n
          d(i)  = - lamspg * g(i)
          xp(i) = x(i) + d(i)
          if ( xp(i) .lt. l(i) .or. xp(i) .gt. u(i) ) then
              xp(i) = max( l(i), min( xp(i), u(i) ) )
              d(i)  = xp(i) - x(i)
          end if
          gtd   = gtd + g(i) * d(i)
          dsupn = max( dsupn, abs( d(i) ) )
          xsupn = max( xsupn, abs( x(i) ) )
      end do

      if ( iprintinn .ge. 6 ) then
          write(* ,100) xsupn,lamspg,dsupn
          write(10,100) xsupn,lamspg,dsupn
      end if

      call setpdim(n,xp)

      call evalaldim(n,xp,m,lambda,rho,equatn,linear,fp,inform)
      if ( inform .lt. 0 ) return

      alpha = 1.0d0

      if ( iprintinn .ge. 6 ) then
          write(*, 110) alpha,fp,fcnt
          write(10,110) alpha,fp,fcnt
      end if

C     ==================================================================
C     Backtracking
C     ==================================================================

      call backtracking(n,x,m,lambda,rho,equatn,linear,f,d,gtd,alpha,fp,
     +xp,evalaldim,setpdim,lsinfo,inform)
      if ( inform .lt. 0 ) return

C     ==================================================================
C     End of backtracking
C     ==================================================================

C     NON-EXECUTABLE STATEMENTS

 100  format(/,5X,'SPG Line search (xsupn = ',1P,D7.1,1X,'SPGstep= ',
     +             1P,D7.1,1X,'dsupn = ',1P,D7.1,')')
 110  format(  5X,'Alpha = ',1P,D7.1,' F = ',1P,D24.16,' FE = ',I7)

      end
C     *****************************************************************
C     *****************************************************************

      subroutine tnls(nind,x,l,u,m,lambda,rho,equatn,linear,f,g,amax,d,
     +rbdnnz,rbdind,rbdtype,xp,fp,gp,lsinfo,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,lsinfo,m,nind,rbdnnz
      double precision amax,f,fp

C     ARRAY ARGUMENTS
      integer rbdind(nind)
      character rbdtype(nind)
      logical equatn(m),linear(m)
      double precision d(nind),g(*),gp(*),l(nind),lambda(m),rho(m),
     +        u(nind),x(*),xp(*)

C     This subroutine computes a line search in direction d.
C
C     lsinfo:
C
C     At the first trial:
C
C     5: x + amax d is at the boundary and f(x + amax d) is smaller than f

C     Extrapolation:
C
C     2: Unbounded objective function?
C     4: beta-condition holds. No extrapolation is done
C     6: Maximum number of extrapolations reached
C     7: Similar consecutive projected points
C     8: Not-well-defined objective function
C     9: Functional value increases

C     Backtracking:
C
C     0: Armijo satisfied
C     1: Small step with functional value similar to the current one
C     2: Unbounded objective function?
C     3: Too small backtracking step. Wrong gradient?

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      double precision bignum,macheps,macheps12,macheps13,macheps23

C     COMMON BLOCKS
      common /machcon/ bignum,macheps,macheps12,macheps13,macheps23
      save   /machcon/
C     PARAMETERS

C     General constants

      double precision fmin

      parameter ( fmin       = - 1.0d+20 )

C     Line search constants

      integer maxextrap,mininterp
      double precision beta,etaint,etaext,gamma,sigma1,sigma2

      parameter ( maxextrap  =       100 )
      parameter ( mininterp  =         4 )

      parameter ( gamma      =   1.0d-04 )
      parameter ( beta       =     0.5d0 )
      parameter ( sigma1     =     0.1d0 )
      parameter ( sigma2     =     0.9d0 )
      parameter ( etaint     =     2.0d0 )
      parameter ( etaext     =     2.0d0 )

C     Safeguarding spectral step constants

      double precision lspgma,lspgmi

      parameter ( lspgma     =   1.0d+10 )
      parameter ( lspgmi     =   1.0d-10 )

C     Conjugate gradients constants

      integer maxcgitnp
      double precision epsnqmp,theta

      parameter ( theta      =   1.0d-06 )
      parameter ( epsnqmp    =   1.0d-08 )
      parameter ( maxcgitnp  =         5 )

C     BETRA constants

      logical extrp4,extrp5
      integer msmaxit
      double precision mseps,msrho,mssig,phieps,trdelini,trdelmin,
     +        tralpha

      parameter ( extrp4     =   .true. )
      parameter ( extrp5     =   .true. )

      parameter ( msmaxit    =       20 )

      parameter ( mseps      =  1.0d-08 )
      parameter ( mssig      =  1.0d-01 )
      parameter ( msrho      =  9.0d-01 )
      parameter ( phieps     =  1.0d-08 )
      parameter ( trdelini   =  1.0d+02 )
      parameter ( trdelmin   =  1.0d-08 )
      parameter ( tralpha    =  1.0d-01 )

C     GENCAN constants

      integer maxinnitnp
      double precision cggpnf,cgepsi,cgepsf,delmin,eta

      parameter ( maxinnitnp =         3 )
      parameter ( delmin     =   1.0d+04 )
      parameter ( eta        =   0.1d0   )
      parameter ( cggpnf     =   1.0d-04 )
      parameter ( cgepsi     =   1.0d-01 )
      parameter ( cgepsf     =   1.0d-08 )

C     ALGENCAN constants

      logical rhorestart
      integer maxoutitnp,maxoutit
      double precision lammax,lammin,rhofrac,rhoinimax,rhoinimin,rhomax,
     +        rhomult

      parameter ( maxoutitnp =        10 )
      parameter ( maxoutit   =       100 )

      parameter ( lammin     = - 1.0d+20 )
      parameter ( lammax     =   1.0d+20 )

      parameter ( rhofrac    =   0.5d0   )
      parameter ( rhomult    =   1.0d+01 )
      parameter ( rhomax     =   1.0d+20 )

      parameter ( rhorestart =    .true. )
      parameter ( rhoinimin  =   1.0d-08 )
      parameter ( rhoinimax  =   1.0d+08 )
C     COMMON SCALARS
      integer efcnt,efccnt,egcnt,egjccnt,ehcnt,ehlcnt,ehlpcnt,fcnt

C     COMMON ARRAYS
      integer eccnt(mmax),ehccnt(mmax),ejccnt(mmax)

C     COMMON BLOCKS
      common /counters/ eccnt,ehccnt,ejccnt,efcnt,efccnt,egcnt,egjccnt,
     +                  ehcnt,ehlcnt,ehlpcnt,fcnt
      save   /counters/
C     COMMON SCALARS
      logical iprintctl(7)
      integer iprintinn,iprintout,mprint,nprint

C     COMMON BLOCKS
      common /outdat/ iprintctl,iprintinn,iprintout,nprint,mprint
      save   /outdat/


C     LOCAL SCALARS
      logical boundary
      integer i
      double precision alpha,dsupn,gtd,xsupn

C     EXTERNAL SUBROUTINES
      external calcal,csetp

C     ==================================================================
C     ==================================================================

C     Test Armijo condition and beta condition. Decide between accept
C     the first trial, extrapolate or backtrack.

C     ==================================================================
C     ==================================================================

C     ------------------------------------------------------------------
C     Compute directional derivative, dsupn and xsupn
C     ------------------------------------------------------------------

      gtd = 0.0d0
      dsupn = 0.0d0
      xsupn = 0.0d0
      do i = 1,nind
          gtd = gtd + g(i) * d(i)
          dsupn = max( dsupn, abs( d(i) ) )
          xsupn = max( xsupn, abs( x(i) ) )
      end do

      if ( iprintinn .ge. 6 ) then
          write(*, 100) xsupn,amax,dsupn
          write(10,100) xsupn,amax,dsupn
      end if

C     ------------------------------------------------------------------
C     Compute first trial (projected point)
C     ------------------------------------------------------------------

      alpha = 1.0d0

      boundary = .false.
      do i = 1,nind
          xp(i) = x(i) + d(i)

          if ( xp(i) .lt. l(i) .or. xp(i) .gt. u(i) ) then
              boundary = .true.
              xp(i) = max( l(i), min( xp(i), u(i) ) )
          end if
      end do

      if ( amax .eq. 1.0d0 ) then
          boundary = .true.

          do i = 1,rbdnnz
              if ( rbdtype(i) .eq. 'L' ) then
                  xp(rbdind(i)) = l(rbdind(i))
              else if ( rbdtype(i) .eq. 'U' ) then
                  xp(rbdind(i)) = u(rbdind(i))
              end if
          end do
      end if

      call csetp(nind,xp)

      call calcal(nind,xp,m,lambda,rho,equatn,linear,fp,inform)
      if ( inform .lt. 0 ) return

      if ( .not. boundary ) then

          if ( iprintinn .ge. 6 ) then
              write(*, 110) fp,fcnt
              write(10,110) fp,fcnt
          end if

      else
          if ( iprintinn .ge. 6 ) then
              write(*, 120) fp,fcnt
              write(10,120) fp,fcnt
          end if
      end if

C     ------------------------------------------------------------------
C     The first trial is an interior point.
C     ------------------------------------------------------------------

      if ( .not. boundary ) then

          if ( iprintinn .ge. 6 ) then
              write(*, 140)
              write(10,140)
          end if

C         Armijo condition holds.

          if ( fp .le. f + alpha * gamma * gtd ) then

              if ( iprintinn .ge. 6 ) then
                  write(*, 150)
                  write(10,150)
              end if

              go to 1000

          end if

C         Armijo condition does not hold. We will do backtracking.

          if ( iprintinn .ge. 6 ) then
              write(* ,180)
              write(10,180)
          end if

          go to 2000

      end if

C     ------------------------------------------------------------------
C     The first trial is at the boundary.
C     ------------------------------------------------------------------

      if ( iprintinn .ge. 6 ) then
          write(*, 190)
          write(10,190)
      end if

C     Function value is smaller than at the current point. We will
C     extrapolate.

      if ( fp .lt. f ) then

          if ( iprintinn .ge. 6 ) then
              write(*, 200)
              write(10,200)
          end if

          go to 1000

      end if

C     Discard the projected point and consider x + amax d

      if ( iprintinn .ge. 6 ) then
          write(*, 210)
          write(10,210)
      end if

      alpha = amax

      do i = 1,nind
          xp(i) = x(i) + alpha * d(i)
      end do

      do i = 1,rbdnnz
          if ( rbdtype(i) .eq. 'L' ) then
              xp(rbdind(i)) = l(rbdind(i))
          else if ( rbdtype(i) .eq. 'U' ) then
              xp(rbdind(i)) = u(rbdind(i))
          end if
      end do

      call csetp(nind,xp)

      call calcal(nind,xp,m,lambda,rho,equatn,linear,fp,inform)
      if ( inform .lt. 0 ) return

      if ( iprintinn .ge. 6 ) then
          write(*, 130) alpha,fp,fcnt
          write(10,130) alpha,fp,fcnt
      end if

C     Function value is smaller than or equal to (or even just a little
C     bit greater than) at the current point. Line search is over.

      if ( fp .le. f + macheps23 * abs(f) ) then

          if ( iprintinn .ge. 6 ) then
              write(*, 220)
              write(10,220)
          end if

          call calcnal(nind,xp,m,lambda,rho,equatn,linear,gp,inform)
          if ( inform .lt. 0 ) return

          lsinfo = 5

          if ( iprintinn .ge. 6 ) then
              write(*, 900)
              write(10,900)
          end if

          return

      end if

C     Function value is greater than at the current point. We will
C     do backtracking.

      if ( iprintinn .ge. 6 ) then
          write(*, 230)
          write(10,230)
      end if

      go to 2000

C     ==================================================================
C     ==================================================================

C     Extrapolation

C     ==================================================================
C     ==================================================================

 1000 continue

      call extrapolation(nind,x,l,u,m,lambda,rho,equatn,linear,g,xp,fp,
     +gp,d,alpha,amax,rbdnnz,rbdind,rbdtype,fmin,beta,etaext,maxextrap,
     +lsinfo,inform)

      return

C     ==================================================================
C     ==================================================================

C     Backtracking

C     ==================================================================
C     ==================================================================

 2000 continue

      call backtracking(nind,x,m,lambda,rho,equatn,linear,f,d,gtd,alpha,
     +fp,xp,calcal,csetp,lsinfo,inform)
      if ( inform .lt. 0 ) return

      call calcnal(nind,xp,m,lambda,rho,equatn,linear,gp,inform)
      if ( inform .lt. 0 ) return

C     ==================================================================
C     End of backtracking
C     ==================================================================

C     NON-EXECUTABLE STATEMENTS

 100  format(/,5X,'TN Line search (xsupn = ',1P,D7.1,', amax = ',
     +             1P,D7.1,', dsupn = ',1P,D7.1,')')
 110  format(  5X,'Unitary step    F = ',1P,D24.16,' FE = ',I7)
 120  format(  5X,'Projected point F = ',1P,D24.16,' FE = ',I7)
 130  format(  5X,'Alpha = ',1P,D7.1,' F = ',1P,D24.16,' FE = ',I7)
 140  format(  5X,'The first trial is an interior point.')
 150  format(  5X,'Armijo condition holds.')
 180  format(  5X,'Armijo condition does not hold. We will backtrack.')
 190  format(  5X,'The first trial is at the boundary.')
 200  format(  5X,'Function value at the boundary is smaller than at ',
     +            'the current point.',/,5X,'We will extrapolate.')
 210  format(  5X,'Discarding projected point. We will now consider x ',
     +            '+ amax d.')
 220  format(  5X,'Function value at the boundary is smaller than or ',
     +            'equal to than at the',/,5X,'current point. Line ',
     +            'search is over.')
 230  format(  5X,'Function value at the boundary is greater than at ',
     +            'the current point.',/,5X,'We will backtrack.')
 900  format(  5X,'Flag of TN Line search: First trial accepted.')

      end
      subroutine backtracking(dim,x,m,lambda,rho,equatn,linear,f,d,gtd,
     +alpha,fp,xp,evalaldim,setpdim,btinfo,inform)

C     SCALAR ARGUMENTS
      integer btinfo,dim,inform,m
      double precision alpha,f,fp,gtd

C     ARRAY ARGUMENTS
      logical equatn(m),linear(m)
      double precision d(dim),lambda(m),rho(m),x(dim),xp(*)

C     SUBROUTINE ARGUMENTS
      external evalaldim,setpdim

C     Backtracking with quadratic interpolation.
C
C     btinfo:
C
C     0: Armijo satisfied
C     2: Unbounded objective function?
C     3: Too small backtracking step. Wrong gradient?

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      double precision bignum,macheps,macheps12,macheps13,macheps23

C     COMMON BLOCKS
      common /machcon/ bignum,macheps,macheps12,macheps13,macheps23
      save   /machcon/
C     PARAMETERS

C     General constants

      double precision fmin

      parameter ( fmin       = - 1.0d+20 )

C     Line search constants

      integer maxextrap,mininterp
      double precision beta,etaint,etaext,gamma,sigma1,sigma2

      parameter ( maxextrap  =       100 )
      parameter ( mininterp  =         4 )

      parameter ( gamma      =   1.0d-04 )
      parameter ( beta       =     0.5d0 )
      parameter ( sigma1     =     0.1d0 )
      parameter ( sigma2     =     0.9d0 )
      parameter ( etaint     =     2.0d0 )
      parameter ( etaext     =     2.0d0 )

C     Safeguarding spectral step constants

      double precision lspgma,lspgmi

      parameter ( lspgma     =   1.0d+10 )
      parameter ( lspgmi     =   1.0d-10 )

C     Conjugate gradients constants

      integer maxcgitnp
      double precision epsnqmp,theta

      parameter ( theta      =   1.0d-06 )
      parameter ( epsnqmp    =   1.0d-08 )
      parameter ( maxcgitnp  =         5 )

C     BETRA constants

      logical extrp4,extrp5
      integer msmaxit
      double precision mseps,msrho,mssig,phieps,trdelini,trdelmin,
     +        tralpha

      parameter ( extrp4     =   .true. )
      parameter ( extrp5     =   .true. )

      parameter ( msmaxit    =       20 )

      parameter ( mseps      =  1.0d-08 )
      parameter ( mssig      =  1.0d-01 )
      parameter ( msrho      =  9.0d-01 )
      parameter ( phieps     =  1.0d-08 )
      parameter ( trdelini   =  1.0d+02 )
      parameter ( trdelmin   =  1.0d-08 )
      parameter ( tralpha    =  1.0d-01 )

C     GENCAN constants

      integer maxinnitnp
      double precision cggpnf,cgepsi,cgepsf,delmin,eta

      parameter ( maxinnitnp =         3 )
      parameter ( delmin     =   1.0d+04 )
      parameter ( eta        =   0.1d0   )
      parameter ( cggpnf     =   1.0d-04 )
      parameter ( cgepsi     =   1.0d-01 )
      parameter ( cgepsf     =   1.0d-08 )

C     ALGENCAN constants

      logical rhorestart
      integer maxoutitnp,maxoutit
      double precision lammax,lammin,rhofrac,rhoinimax,rhoinimin,rhomax,
     +        rhomult

      parameter ( maxoutitnp =        10 )
      parameter ( maxoutit   =       100 )

      parameter ( lammin     = - 1.0d+20 )
      parameter ( lammax     =   1.0d+20 )

      parameter ( rhofrac    =   0.5d0   )
      parameter ( rhomult    =   1.0d+01 )
      parameter ( rhomax     =   1.0d+20 )

      parameter ( rhorestart =    .true. )
      parameter ( rhoinimin  =   1.0d-08 )
      parameter ( rhoinimax  =   1.0d+08 )
C     COMMON SCALARS
      integer efcnt,efccnt,egcnt,egjccnt,ehcnt,ehlcnt,ehlpcnt,fcnt

C     COMMON ARRAYS
      integer eccnt(mmax),ehccnt(mmax),ejccnt(mmax)

C     COMMON BLOCKS
      common /counters/ eccnt,ehccnt,ejccnt,efcnt,efccnt,egcnt,egjccnt,
     +                  ehcnt,ehlcnt,ehlpcnt,fcnt
      save   /counters/
C     COMMON SCALARS
      logical iprintctl(7)
      integer iprintinn,iprintout,mprint,nprint

C     COMMON BLOCKS
      common /outdat/ iprintctl,iprintinn,iprintout,nprint,mprint
      save   /outdat/


C     LOCAL SCALARS
      logical samep
      integer i,interp
      double precision atmp

      interp = 0

 2010 continue

C     Test Armijo condition

      if ( fp .le. f + alpha * gamma * gtd ) then

C         Finish backtracking with the current point

          btinfo = 0

          if ( iprintinn .ge. 6 ) then
              write(*, 900)
              write(10,900)
          end if

          return

      end if

C     Test f going to -inf

      if ( fp .le. fmin ) then

C         Finish backtracking with the current point

          btinfo = 2

          if ( iprintinn .ge. 6 ) then
              write(*, 920)
              write(10,920)
          end if

          return

      end if

C     Test if we obtained a functional value similar to the current one
C     associated to a very small step

      samep = .true.
      do i = 1,dim
          if ( xp(i) .gt. x(i) + macheps23 * max(1.0d0,abs(x(i))) .or.
     +         xp(i) .lt. x(i) - macheps23 * max(1.0d0,abs(x(i))) ) then
              samep = .false.
          end if
      end do

      if ( samep .and. fp .le. f + macheps23 * abs(f) ) then

C         Finish backtracking with the current point

          btinfo = 3

          if ( iprintinn .ge. 6 ) then
              write(*, 930)
              write(10,930)
          end if

          return

      end if

C     Compute new step

      interp = interp + 1

      atmp = ( - gtd * alpha ** 2 ) /
     +       ( 2.0d0 * ( fp - f - alpha * gtd ) )

      if ( atmp .ge. sigma1 * alpha .and.
     +     atmp .le. sigma2 * alpha ) then
          alpha = atmp
      else
          alpha = alpha / etaint
      end if

C     Compute new trial point

      do i = 1,dim
          xp(i) = x(i) + alpha * d(i)
      end do

      call setpdim(dim,xp)

      call evalaldim(dim,xp,m,lambda,rho,equatn,linear,fp,inform)
      if ( inform .lt. 0 ) return

C     Print information of this iteration

      if ( iprintinn .ge. 6 ) then
          write(*, 110) alpha,fp,fcnt
          write(10,110) alpha,fp,fcnt
      end if

      go to 2010

C     NON-EXECUTABLE STATEMENTS

 110  format(  5X,'Alpha = ',1P,D7.1,' F = ',1P,D24.16,' FE = ',I7)
 900  format(  5X,'Flag of backtracking: Armijo condition holds.')
 920  format(  5X,'Flag of backtracking: Unbounded objective function?')
 930  format(  5X,'Flag of backtracking: Too small backtracking step.')

      end
C     *****************************************************************
C     *****************************************************************

      subroutine extrapolation(nind,x,l,u,m,lambda,rho,equatn,linear,g,
     +xp,fp,gp,d,alpha,amax,rbdnnz,rbdind,rbdtype,fmin,beta,etaext,
     +maxextrap,extinfo,inform)

C     SCALAR ARGUMENTS
      integer extinfo,inform,m,maxextrap,nind,rbdnnz
      double precision alpha,amax,beta,etaext,fmin,fp

C     ARRAY ARGUMENTS
      logical equatn(m),linear(m)
      character rbdtype(nind)
      integer rbdind(nind)
      double precision d(nind),g(*),gp(*),l(nind),lambda(m),rho(m),
     +        u(nind),x(*),xp(*)

C     Performs extrapolation.
C
C     extinfo:
C
C     0: Success
C     2: Unbounded objective function?
C     4: beta-condition holds. No extrapolation is done
C     6: Maximum number of extrapolations reached
C     7: Similar consecutive projected points
C     8: Not-well-defined objective function
C     9: Functional value increases

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      integer efcnt,efccnt,egcnt,egjccnt,ehcnt,ehlcnt,ehlpcnt,fcnt

C     COMMON ARRAYS
      integer eccnt(mmax),ehccnt(mmax),ejccnt(mmax)

C     COMMON BLOCKS
      common /counters/ eccnt,ehccnt,ejccnt,efcnt,efccnt,egcnt,egjccnt,
     +                  ehcnt,ehlcnt,ehlpcnt,fcnt
      save   /counters/
C     COMMON SCALARS
      double precision bignum,macheps,macheps12,macheps13,macheps23

C     COMMON BLOCKS
      common /machcon/ bignum,macheps,macheps12,macheps13,macheps23
      save   /machcon/
C     COMMON SCALARS
      logical iprintctl(7)
      integer iprintinn,iprintout,mprint,nprint

C     COMMON BLOCKS
      common /outdat/ iprintctl,iprintinn,iprintout,nprint,mprint
      save   /outdat/


C     LOCAL SCALARS
      logical projected,samep
      integer extrap,i
      double precision atmp,fbext,ftmp,gptd,gtd

C     LOCAL ARRAYS
      double precision xbext(nmax),xtmp(nmax)

      extinfo = 0

      extrap  = 0

C     Compute directional derivative

      gtd = 0.0d0
      do i = 1,nind
          gtd = gtd + g(i) * d(i)
      end do

      call calcnal(nind,xp,m,lambda,rho,equatn,linear,gp,inform)
      if ( inform .lt. 0 ) return

      gptd = 0.0d0
      do i = 1,nind
          gptd = gptd + gp(i) * d(i)
      end do

C     Beta condition holds. No extrapolation is done.

      if ( gptd .ge. beta * gtd ) then

          if ( iprintinn .ge. 6 ) then
              write(*, 110)
              write(10,110)
          end if

          extinfo = 4

          return

      end if

C     Beta condition does not holds. We will extrapolate.

      if ( iprintinn .ge. 6 ) then
          write(* ,120)
          write(10,120)
      end if

C     Save f and x before extrapolation to return in case of a
C     not-well-defined objective function at an extrapolated point

      fbext = fp

      do i = 1,nind
          xbext(i) = xp(i)
      end do

 1010 continue

C     Test f going to -inf

      if ( fp .le. fmin ) then

C         Finish the extrapolation with the current point

          if ( extrap .ne. 0 ) then
              call calcnal(nind,xp,m,lambda,rho,equatn,linear,gp,inform)
              if ( inform .lt. 0 ) return
          end if

          extinfo = 2

          if ( iprintinn .ge. 6 ) then
              write(*, 910)
              write(10,910)
          end if

          return

      end if

C     Test if the maximum number of extrapolations was exceeded

      if ( extrap .ge. maxextrap ) then

C         Finish the extrapolation with the current point

          if ( extrap .ne. 0 ) then
              call calcnal(nind,xp,m,lambda,rho,equatn,linear,gp,inform)
              if ( inform .lt. 0 ) return
          end if

          extinfo = 6

          if ( iprintinn .ge. 6 ) then
              write(*, 930)
              write(10,930)
          end if

          return

      end if

C     Chose new step

      extrap = extrap + 1

      if ( alpha .lt. amax .and. etaext * alpha .gt. amax ) then
          atmp = amax
      else
          atmp = etaext * alpha
      end if

C     Compute new trial point

      do i = 1,nind
          xtmp(i) = x(i) + atmp * d(i)
      end do

      if ( atmp .eq. amax ) then
          do i = 1,rbdnnz
              if ( rbdtype(i) .eq. 'L' ) then
                  xtmp(rbdind(i)) = l(rbdind(i))
              else if ( rbdtype(i) .eq. 'U' ) then
                  xtmp(rbdind(i)) = u(rbdind(i))
              end if
          end do
      end if

C     Project

      if ( atmp .gt. amax ) then

          projected = .false.
          do i = 1,nind
              if ( xtmp(i) .lt. l(i) .or. xtmp(i) .gt. u(i) ) then
                  projected = .true.
                  xtmp(i) = max( l(i), min( xtmp(i), u(i) ) )
              end if
          end do

      end if

C     Test if this is not the same point as the previous one. This test
C     is performed only when xtmp is in fact a projected point.

      if ( projected ) then

          samep = .true.
          do i = 1,nind
              if ( xtmp(i) .gt. 
     +             xp(i) + macheps23 * max( 1.0d0, abs( xp(i) ) ) .or.
     +             xtmp(i) .lt. 
     +             xp(i) - macheps23 * max( 1.0d0, abs( xp(i) ) ) ) then
                  samep = .false.
              end if
          end do

          if ( samep ) then

C             Finish the extrapolation with the current point

              call calcnal(nind,xp,m,lambda,rho,equatn,linear,gp,inform)
              if ( inform .lt. 0 ) return

              extinfo = 7

              if ( iprintinn .ge. 6 ) then
                  write(*, 940)
                  write(10,940)
              end if

              return

          end if

      end if

C     Evaluate function

      call csetp(nind,xtmp)

      call calcal(nind,xtmp,m,lambda,rho,equatn,linear,ftmp,inform)

C     If the objective function is not well defined in an extrapolated
C     point, we discard all the extrapolated points and return to a
C     safe region (to the last point before the extrapolation)

      if ( inform .lt. 0 ) then

          fp = fbext

          do i = 1,nind
              xp(i) = xbext(i)
          end do

          call csetp(nind,xp)

          call calcnal(nind,xp,m,lambda,rho,equatn,linear,gp,inform)
          if ( inform .lt. 0 ) return

          extinfo = 8

          if ( iprintinn .ge. 6 ) then
              write(*, 950)
              write(10,950)
          end if

          return

      end if

C     Print information of this iteration

      if ( iprintinn .ge. 6 ) then
          write(*, 100) atmp,ftmp,fcnt
          write(10,100) atmp,ftmp,fcnt
      end if

C     If the functional value decreases then set the current point and
C     continue the extrapolation

      if ( ftmp .lt. fp ) then

          alpha = atmp

          fp = ftmp

          do i = 1,nind
              xp(i) = xtmp(i)
          end do

          go to 1010

      end if

C     If the functional value does not decrease then discard the last
C     trial and finish the extrapolation with the previous point

      call csetp(nind,xp)

      call calcnal(nind,xp,m,lambda,rho,equatn,linear,gp,inform)
      if ( inform .lt. 0 ) return

      extinfo = 9

      if ( iprintinn .ge. 6 ) then
          write(*, 960)
          write(10,960)
      end if

C     NON-EXECUTABLE STATEMENTS

 100  format(  5X,'Alpha = ',1P,D7.1,' F = ',1P,D24.16,' FE = ',I7)
 110  format(  5X,'Beta condition also holds. ',
     +            'No extrapolation is done.')
 120  format(  5X,'Beta condition does not hold. We will extrapolate.')

 910  format(  5X,'Flag of Extrapolation: Unbounded objective ',
     +            'function?')
 930  format(  5X,'Flag of Extrapolation: Maximum of consecutive ',
     +            'extrapolations reached.')
 940  format(  5X,'Flag of Extrapolation: Very similar consecutive ',
     +            'projected points.')
 950  format(  5X,'Flag of Extrapolation: Not-well-defined objective ',
     +            'function in an extrapolated point.')
 960  format(  5X,'Flag of Extrapolation: Functional value increased ',
     +            'when extrapolating.')

      end
C     ******************************************************************
C     ******************************************************************

      subroutine newtonkkt(n,xo,lo,uo,m,lambdao,equatno,linearo,epsfeas,
     +epsopt,f,cnorm,nlnorm,iter,msqiter,accinfo,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer accinfo,inform,iter,m,msqiter,n
      double precision cnorm,epsfeas,epsopt,f,nlnorm

C     ARRAY ARGUMENTS
      logical equatno(m),linearo(m)
      double precision lo(n),lambdao(m),uo(n),xo(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      double precision bignum,macheps,macheps12,macheps13,macheps23

C     COMMON BLOCKS
      common /machcon/ bignum,macheps,macheps12,macheps13,macheps23
      save   /machcon/
C     COMMON SCALARS
      character * 6 hptype
      character * 2 innslvr
      logical ccoded,fccoded,fcoded,gcoded,gjaccoded,innercall,jaccoded,
     +        hcoded,hccoded,hlcoded,hlpcoded,firstde,truehl,ignoref,
     +        skipacc,sclsys,useustp,safemode

C     COMMON BLOCKS
      common /algparam/ fcoded,gcoded,hcoded,ccoded,jaccoded,hccoded,
     +                  hlcoded,hlpcoded,fccoded,gjaccoded,firstde,
     +                  truehl,ignoref,skipacc,sclsys,innercall,useustp,
     +                  innslvr,hptype,safemode
      save   /algparam/
C     COMMON SCALARS
      logical iprintctl(7)
      integer iprintinn,iprintout,mprint,nprint

C     COMMON BLOCKS
      common /outdat/ iprintctl,iprintinn,iprintout,nprint,mprint
      save   /outdat/

C     COMMON SCALARS
      logical constrc,gotc

C     COMMON ARRAYS
      integer jcvar(jcnnzmax),jcsta(mmax),jclen(mmax)
      double precision c(mmax),dpdc(mmax),g(nmax),gparc(nmax),
     +        jcval(jcnnzmax)

C     COMMON BLOCKS
      common /gdata/ g,gparc,c,dpdc,jcval,jcvar,jcsta,jclen,constrc,gotc
      save   /gdata/
C     COMMON SCALARS
      integer hnnz

C     COMMON ARRAYS
      integer hcol(hnnzmax),hlin(hnnzmax)
      double precision hval(hnnzmax)

C     COMMON BLOCKS
      common /hdata/ hval,hlin,hcol,hnnz
      save   /hdata/

C     accinfo:
C
C     0: KKT system solved.
C     1: Ignored constraints were violated.
C     2: After correcting the Lagrange multipliers signal, optimality
C        was lost.
C     3: Maximum number of iterations reached.
C     4: Newton seems to be diverging.
C     5: Singular Jacobian.
C     6: Insufficient space to store the KKT linear system.
C     7: Insufficient double precision working space for linear solver.
C     8: Insufficient integer working space for linear solver.

C     PARAMETERS
      integer mtotmax,ntotmax
      parameter ( mtotmax  = mmax + 2 * nmax )
      parameter ( ntotmax  = mmax + 3 * nmax )

C     LOCAL SCALARS
      integer cind,col,divit,fun,hlnnz,i,itmp,j,jcnnz,k,lssinfo,lin,
     +        maxit,minp,mnop,mtot,nbds,nineq,ninn,nneigv,nnon,nsys,
     +        ntot,pind,sind,var,vind
      double precision rnorm,rnorm0,rnormprev,rnormref,epsact,epsadd,fu,
     +        nlnorm0,nlnormprev,nlnormref,pval,sgnvio,val

C     LOCAL ARRAYS
      logical equatn(mtotmax),linear(mmax)
      character constt(2*nmax),status(nmax)
      integer consti(2*nmax),hdiag(ntotmax+mtotmax),inn(ntotmax),
     +        inp(mtotmax),jcfun(jcnnzmax),slaind(mtotmax)
      double precision adddiag(ntotmax+mtotmax),b(ntotmax+mtotmax),
     +        l(ntotmax),lambda(mtotmax),nl(ntotmax),r(mtotmax),
     +        ru(mmax),t(nmax),u(ntotmax),x(ntotmax)

C     ==================================================================
C     PRESENTATION
C     ==================================================================

      if ( iprintout .ge. 1 ) then
          write(* ,8000)
          write(10,8000)
      end if

C     ==================================================================
C     INITIALIZE
C     ==================================================================

      iter    =  0
      divit   =  0
      maxit   = 10
      msqiter =  0

      epsact = sqrt( epsfeas )
      epsadd = macheps12

      call lssini(sclsys,.true.,.false.)

C     ==================================================================
C     SET INITIAL POINT
C     ==================================================================

      do i = 1,n
          l(i) = lo(i)
          u(i) = uo(i)
          x(i) = max( lo(i), min( xo(i), uo(i) ) )
          if ( lo(i) .eq. uo(i) ) then
              write(*,*) 'There is a fixed variable: ',i,lo(i),xo(i)
          end if
      end do

      do j = 1,m
          lambda(j) = lambdao(j)
          equatn(j) = equatno(j)
          linear(j) = linearo(j)
      end do

C     ==================================================================
C     COMPUTE CONSTRAINTS AND GRADIENT OF THE LAGRANGIAN
C     ==================================================================

C     Objective function and constraints

      call ssetp(n,x)

      call sevalobjc(n,x,f,fu,m,r,ru,inform)
      if ( inform .lt. 0 ) return

C     Gradient of the Lagrangian (and save Jacobian of the constraints)

      call sevalnl(n,x,m,lambda,equatn,linear,nl,inform)
      if ( inform .lt. 0 ) return

C     ==================================================================
C     STRUCTURES FOR NEW VARIABLES AND (BOUND) CONSTRAINTS
C     SET SLACKS VARIABLES VALUES
C     ==================================================================

C     Relate constraints to slacks

      nineq = 0
      do j = 1,m
          if ( .not. equatn(j) ) then
              nineq     = nineq + 1
              sind      = n + nineq
              slaind(j) = sind
              x(sind)   = sqrt( 2.0d0 * max( 0.0d0, - r(j) ) )
          else
              slaind(j) = 0
          end if
      end do

      nbds = 0
      do i = 1,n
          if ( l(i) .gt. - 1.0d+20 ) then
              nbds = nbds + 1
              constt(nbds) = 'L'
              consti(nbds) =  i
              cind         = m + nbds
              sind         = n + nineq + nbds
              slaind(cind) = sind
              r(cind)      = l(i) - x(i)
              x(sind)      = sqrt( 2.0d0 * max( 0.0d0, - r(cind) ) )
              r(cind)      = r(cind) + 0.5d0 * x(sind) ** 2
              equatn(cind) = .true.
          end if

          if ( u(i) .lt. 1.0d+20 .and. u(i) .ne. l(i) ) then
              nbds = nbds + 1
              constt(nbds) = 'U'
              consti(nbds) =  i
              cind         = m + nbds
              sind         = n + nineq + nbds
              slaind(cind) = sind
              r(cind)      = x(i) - u(i)
              x(sind)      = sqrt( 2.0d0 * max( 0.0d0, - r(cind) ) )
              r(cind)      = r(cind) + 0.5d0 * x(sind) ** 2
              equatn(cind) = .true.
          end if
      end do

      mtot = m + nbds
      ntot = n + nineq + nbds

C     ==================================================================
C     MAIN LOOP
C     ==================================================================

 100  continue

C     ==================================================================
C     SET ACTIVE CONSTRAINTS AND VARIABLES
C     ==================================================================

C     A fixed variable will be fixed forever.

      minp = 0
      mnop = 0

      ninn = 0
      nnon = 0

C     Set active variables

      do i = 1,n
           if ( x(i) .le. l(i) ) then
               status(i) = 'L'
               x(i) = l(i)

               nnon   = nnon + 1
               inn(i) = ntot + 1 - nnon

           else if ( x(i) .ge. u(i) ) then

               status(i) = 'U'
               x(i) = u(i)

               nnon   = nnon + 1
               inn(i) = ntot + 1 - nnon

           else
              status(i) = 'F'
              ninn   = ninn + 1
              inn(i) = ninn
           end if
      end do

C     Set active (regular) constraints and their slacks

      do j = 1,m
          if ( equatn(j) ) then
C             Active equality constraint
              minp   = minp + 1
              inp(j) = minp
          else
              sind = slaind(j)

              if ( r(j) .ge. - epsact ) then
C                 Active inequality constraint and its slack
                  minp      = minp + 1
                  inp(j)    = minp

                  ninn      = ninn + 1
                  inn(sind) = ninn
              else
C                 Deactivate inequality constraint and its slack
                  mnop      = mnop + 1
                  inp(j)    = mtot + 1 - mnop

                  nnon      = nnon + 1
                  inn(sind) = ntot + 1 - nnon
              end if
          end if
      end do

C     Set active bound constraints and their slacks

      do i = 1,nbds
          cind = m + i
          vind = consti(i)
          sind = slaind(cind)

          if ( status(vind) .eq. 'F' ) then
              minp      = minp + 1
              inp(cind) = minp

              ninn      = ninn + 1
              inn(sind) = ninn

          else
              mnop      = mnop + 1
              inp(cind) = mtot + 1 - mnop

              nnon      = nnon + 1
              inn(sind) = ntot + 1 - nnon

              if ( constt(i) .eq. status(vind) ) then
                  x(sind) = 0.0d0
              else
                  x(sind) = sqrt( 2.0d0 * ( u(vind) - l(vind) ) )
              end if
          end if
      end do

      nsys = ninn + minp

C     ==================================================================
C     SAVE NORMS TO CHECK IMPROVEMENT
C     ==================================================================

      if ( iter .eq. 0 ) then
          nlnormprev = bignum
          rnormprev  = bignum
      else
          nlnormprev = nlnorm
          rnormprev  = rnorm
      end if

C     ==================================================================
C     COMPUTE OBJECTIVE FUNCTION AND CONSTRAINTS
C     ==================================================================

C     Objective function and constraints

      call ssetp(n,x)

      call sevalobjc(n,x,f,fu,m,r,ru,inform)
      if ( inform .lt. 0 ) return

C     Violation of original constraints

      cnorm = 0.0d0
      do i = 1,m
          if ( equatn(i) ) then
              cnorm = max( cnorm, abs( r(i) ) )
          else
              cnorm = max( cnorm, r(i) )
          end if
      end do

C     Add slacks effect

C     Regular constraints

      do j = 1,m
          sind = slaind(j)
          if ( sind .ne. 0 ) then
              r(j) = r(j) + 0.5d0 * x(sind) ** 2
          end if
      end do

C     Bound constraints

      do i = 1,nbds
          cind = m + i
          sind = slaind(cind)
          vind = consti(i)
          if ( constt(i) .eq. 'L' ) then
              r(cind) = l(vind) - x(vind)
          else
              r(cind) = x(vind) - u(vind)
          end if

          r(cind) = r(cind) + 0.5d0 * x(sind) ** 2
      end do

C     Constraints norm

      rnorm = 0.0d0
      do j = 1,mtot
          rnorm = max( rnorm, abs( r(j) ) )
      end do

      if ( iter .eq. 0 ) then
          rnorm0 = rnorm
      end if

C     ==================================================================
C     COMPUTE FIRST DERIVATIVES
C     ==================================================================

C     Gradient of the objective function and Jacobian of the constraints

      if ( gjaccoded ) then

          call sevalgjac(n,x,t,m,jcfun,jcvar,jcval,jcnnz,inform)
          if ( inform .lt. 0 ) return

C         --- Teste ---
C         --- Teste ---
c         do i = 1,n
c             nl(i) = t(i)
c         end do
c         do i = 1,jcnnz
c             nl(jcvar(i)) = nl(jcvar(i)) + lambda(jcfun(i)) * jcval(i)
c         end do
c         nlnorm = 0.0d0
c         do i = 1,n
c             nlpi = x(i) - nl(i)
c             if ( l(i) .le. nlpi .and. nlpi .le. u(i) ) then
c                 nlpi = - nl(i)
c             else
c                 nlpi = max( l(i), min( nlpi, u(i) ) ) - x(i)
c             end if
c             nlnorm = max( nlnorm, abs( nlpi ) )
c         end do
C         --- Teste ---
C         --- Teste ---

C         First derivative related to the slacks of the regular
C         constraints

          do j = 1,m
              sind = slaind(j)

              if ( sind .ne. 0 ) then
                  jcnnz = jcnnz + 1

                  jcfun(jcnnz) = j
                  jcvar(jcnnz) = sind
                  jcval(jcnnz) = x(sind)
              end if
          end do

          call coo2csr(m,jcnnz,jcfun,jcvar,jcval,jclen,jcsta)

      else

C         Gradient of the objective function

          call sevalg(n,x,t,inform)
          if ( inform .lt. 0 ) return

C         --- Teste ---
C         --- Teste ---
c         do i = 1,n
c             nl(i) = t(i)
c         end do
C         --- Teste ---
C         --- Teste ---

C         Jacobian of regular constraints with the slacks effect

          k = 0

          do j = 1,m
              jcsta(j) = k + 1

              call sevaljac(n,x,j,jcvar(k+1),jcval(k+1),jclen(j),inform)
              if ( inform .lt. 0 ) return

              k = k + jclen(j)

C             --- Teste ---
C             --- Teste ---
c             do i = jcsta(j),jcsta(j) + jclen(j) - 1
c                 nl(jcvar(i)) = nl(jcvar(i)) + lambda(j) * jcval(i)
c             end do
C             --- Teste ---
C             --- Teste ---

C             First derivative related to the slacks of the regular
C             constraints

              sind = slaind(j)

              if ( sind .ne. 0 ) then
                  jclen(j) = jclen(j) + 1

                  jcvar(k+1) = sind
                  jcval(k+1) = x(sind)

                  k = k + 1
              end if
          end do

          jcnnz = k

C         --- Teste ---
C         --- Teste ---
c         nlnorm = 0.0d0
c         do i = 1,n
c             nlpi = x(i) - nl(i)
c             if ( l(i) .le. nlpi .and. nlpi .le. u(i) ) then
c                 nlpi = - nl(i)
c             else
c                 nlpi = max( l(i), min( nlpi, u(i) ) ) - x(i)
c             end if
c             nlnorm = max( nlnorm, abs( nlpi ) )
c         end do
C         --- Teste ---
C         --- Teste ---

      end if

C     --- Teste ---
C     --- Teste ---
c     nlnormtmp = nlnorm
C     --- Teste ---
C     --- Teste ---

C     Bound constraints with the slacks effect

      do i = 1,nbds
          cind = m + i
          sind = slaind(cind)
          vind = consti(i)

          jcsta(cind) = jcnnz + 1
          jclen(cind) = 2

          jcvar(jcnnz+1) = vind
          if ( constt(i) .eq. 'L' ) then
              jcval(jcnnz+1) = - 1.0d0
          else
              jcval(jcnnz+1) =   1.0d0
          end if

          jcvar(jcnnz+2) = sind
          jcval(jcnnz+2) = x(sind)

          jcnnz = jcnnz + jclen(cind)
      end do

C     Gradient of the Lagrangian

      do i = 1,ntot
          nl(i) = 0.0d0
      end do

C     Gradient of the objective function

      do i = 1,n
          nl(i) = nl(i) + t(i)
      end do

C     Effect of the Jacobian of regular constraints

      do j = 1,m
          do i = jcsta(j),jcsta(j) + jclen(j) - 1
              nl(jcvar(i)) = nl(jcvar(i)) + lambda(j) * jcval(i)
          end do
      end do

C     Set Lagrange multipliers related to bound constraints

      do i = 1,nbds
          cind = m + i
          vind = consti(i)
          if ( status(vind) .ne. 'F' ) then
              if ( constt(i) .eq. status(vind) ) then
                  if ( constt(i) .eq. 'L' ) then
                      lambda(cind) =   nl(vind)
                  else
                      lambda(cind) = - nl(vind)
                  end if
              else
                  lambda(cind) = 0.0d0
              end if
          else
              lambda(cind) = 0.0d0
          end if
      end do

C     Effect of Jacobian of bound constraints

      do j = m + 1,m + nbds
          do i = jcsta(j),jcsta(j) + jclen(j) - 1
              nl(jcvar(i)) = nl(jcvar(i)) + lambda(j) * jcval(i)
          end do
      end do

C     Gradient of the Lagrangian norm

      nlnorm = 0.0d0
      do i = 1,ntot
          nlnorm = max( nlnorm, abs( nl(i) ) )
      end do

      if ( iter .eq. 0 ) then
          nlnorm0 = nlnorm
      end if

C     ==================================================================
C     WRITE INFORMATION OF THE CURRENT POINT
C     ==================================================================

      if ( iprintout .ge. 1 ) then
          write(* ,8010) iter,f,rnorm,nlnorm
          write(10,8010) iter,f,rnorm,nlnorm
c         write(* ,8010) iter,f,rnorm,nlnormtmp,nlnorm
c         write(10,8010) iter,f,rnorm,nlnormtmp,nlnorm
      end if

C     ==================================================================
C     TEST STOPPING CRITERIA
C     ==================================================================

      if ( rnorm .le. epsfeas .and. nlnorm .le. epsopt ) then
        ! THE POINT SATISFIES FEASIBILITY AND OPTIMALITY

        ! (Ignored constraints and Lagrange multipliers signal
        !  constraint must be checked)

          go to 400
      end if

      if ( iter .ge. maxit ) then
        ! MAXIMUM NUMBER OF ITERATIONS EXCEEDED

          accinfo = 3

          if ( iprintout .ge. 1 ) then
              write(* ,9030)
              write(10,9030)
          end if

          go to 500
      end if

      rnormref  = max(rnorm0 ,max(rnormprev ,max(epsfeas, 1.0d+01)))
      nlnormref = max(nlnorm0,max(nlnormprev,max(epsopt,  1.0d+01)))

      if ( rnorm .gt. rnormref  .or. nlnorm .gt. nlnormref .or.
     +     rnorm .eq. rnormprev .or. nlnorm .eq. nlnormprev ) then
        ! IT SEEMS TO BE DIVERGING

          divit = divit + 1

          if ( divit .ge. 3 ) then

              accinfo = 4

              if ( iprintout .ge. 1 ) then
                  write(* ,9040)
                  write(10,9040)
              end if

              go to 500

          end if

      else
          divit = 0
      end if

C     ==================================================================
C     DO AN ITERATION
C     ==================================================================

      iter = iter + 1

C     ==================================================================
C     COMPUTE SECOND DERIVATIVES
C     ==================================================================

C     Hessian of the Lagrangian

      call sevalhl(n,x,m,lambda,hlin,hcol,hval,hlnnz,inform)
      if ( inform .lt. 0 ) return

C     Second derivatives related to slacks of the regular constraints

      do j = 1,m
          sind = slaind(j)

          if ( sind .ne. 0 ) then
              hlnnz = hlnnz + 1

              hlin(hlnnz) = sind
              hcol(hlnnz) = sind
              hval(hlnnz) = lambda(j)
          end if
      end do

C     Second derivatives related to slacks of the bound constraints

      do i = 1,nbds
          cind = m + i
          sind = slaind(cind)

          hlnnz = hlnnz + 1

          hlin(hlnnz) = sind
          hcol(hlnnz) = sind
          hval(hlnnz) = lambda(cind)
      end do

C     ==================================================================
C     ASSEMBLE THE JACOBIAN OF THE KKT SYSTEM
C     ==================================================================

      hnnz = 0

      do i = 1,nsys
          hdiag(i) = 0
      end do

C     Hessian of the Lagrangian

      do i = 1,hlnnz
          if ( hlin(i) .ge. hcol(i) ) then

              lin = inn(hlin(i))
              col = inn(hcol(i))
              val = hval(i)

              if ( lin .le. ninn .and. col .le. ninn ) then
                  if ( val .ne. 0.0d0 ) then
C                     A(lin,col) = A(lin,col) + val
                      hnnz = hnnz + 1
                      hlin(hnnz) = lin
                      hcol(hnnz) = col
                      hval(hnnz) = val
                      if ( lin .eq. col ) hdiag(lin) = hnnz
                  end if
              end if

          end if
      end do

C     Jacobian of the constraints

      do j = 1,mtot
          do i = jcsta(j),jcsta(j) + jclen(j) - 1

              fun = inp(j)
              var = inn(jcvar(i))
              val = jcval(i)

              if ( var .le. ninn .and. fun .le. minp ) then
                  if ( val .ne. 0.0d0 ) then
C                     A(fun+ninn,var) = A(fun+ninn,var) + val
                      hnnz = hnnz + 1
                      hlin(hnnz) = fun + ninn
                      hcol(hnnz) = var
                      hval(hnnz) = val
                  end if
              end if

          end do
      end do

      do i = 1,nsys
          if ( hdiag(i) .eq. 0 ) then
              hnnz = hnnz + 1
              hlin(hnnz) = i
              hcol(hnnz) = i
              hval(hnnz) = 0.0d0

              hdiag(i) = hnnz
          end if
      end do

C     ==================================================================
C     ANALYSE SPARSITY PATTERN
C     ==================================================================

      call lssana(nsys,hnnz,hlin,hcol,hval,hdiag,lssinfo)

      if ( lssinfo .eq. 6 ) then
        ! INSUFFICIENT SPACE TO STORE THE LINEAR SYSTEM

          accinfo = 6
          go to 500

      end if

C     ==================================================================
C     SOLVE THE NEWTONIAN SYSTEM
C     ==================================================================

C     ==================================================================
C     COMPUTE REGULARIZATION
C     ==================================================================

 200  continue

      do i = 1,ninn
          adddiag(i) = epsadd
      end do

      do i = ninn + 1,nsys
          adddiag(i) = - macheps12
      end do

C     ==================================================================
C     FACTORIZE THE JACOBIAN OF THE NEWTONIAN SYSTEM
C     ==================================================================

      call lssfac(nsys,hnnz,hlin,hcol,hval,hdiag,adddiag,pind,pval,
     +nneigv,lssinfo)

      if ( lssinfo .eq. 0 .or. lssinfo .eq. 1 ) then

          if ( nneigv .ne. minp ) then
            ! WRONG INERTIA (SEE NOCEDAL AND WRIGHT)

C             Lemma 16.3 [pg. 447]: Suppose the the Jacobian of the
C             constraints has full rank and that the reduced Hessian
C             Z^T H Z is positive definite. Then the Jacobian of the
C             KKT system has ninn positive eigenvalues, minp negative
C             eigenvalues, and no zero eigenvalues.

C             Note that at this point we know that the matrix has no
C             zero eigenvalues. nneigv gives the number of negative
C             eigenvalues.

              epsadd = max( macheps12, epsadd * 10.0d0 )

              if ( iprintout .ge. 1 ) then
                  itmp = ninn+minp-nneigv
                  write(* ,8090) ninn,minp,itmp,nneigv,epsadd
                  write(10,8090) ninn,minp,itmp,nneigv,epsadd
              end if

              go to 200
          end if

      else if ( lssinfo .eq. 2 ) then
        ! SINGULAR JACOBIAN

          epsadd = max( macheps12, epsadd * 10.0d0 )

          if ( iprintout .ge. 1 ) then
              write(* ,8080) epsadd
              write(10,8080) epsadd
          end if

          if ( epsadd .le. 1.0d+20 ) then
              go to 200
          end if

          accinfo = 5

          if ( iprintout .ge. 1 ) then
              write(* ,9050)
              write(10,9050)
          end if

          go to 500

      else if ( lssinfo .eq. 6 ) then
        ! INSUFFICIENT SPACE TO STORE THE LINEAR SYSTEM

          accinfo = 6
          go to 500

      else if ( lssinfo .eq. 7 ) then
        ! INSUFFICIENT DOUBLE PRECISION WORKING SPACE

          accinfo = 7
          go to 500

      else ! if ( lssinfo .eq. 8 ) then
        ! INSUFFICIENT INTEGER WORKING SPACE

          accinfo = 8
          go to 500

      end if

C     ==================================================================
C     SOLVE TRIANGULAR SYSTEMS
C     ==================================================================

C     SET RHS

      do i = 1,ntot
          if ( inn(i) .le. ninn ) then
              b(inn(i)) = - nl(i)
          end if
      end do

      do j = 1,mtot
          if ( inp(j) .le. minp ) then
              b(ninn+inp(j)) = - r(j)
          end if
      end do

C     SOLVE THE EQUATIONS

      call lsssol(nsys,b)

C     ==================================================================
C     UPDATE x AND lambda
C     ==================================================================

      do i = 1,ntot
          if ( inn(i) .le. ninn ) then
              x(i) = x(i) + b(inn(i))
          end if
      end do

      do j = 1,mtot
          if ( inp(j) .le. minp ) then
              lambda(j) = lambda(j) + b(ninn+inp(j))
          end if
      end do

C     ==================================================================
C     ITERATE
C     ==================================================================

      go to 100

C     ==================================================================
C     END OF MAIN LOOP
C     ==================================================================

C     ==================================================================
C     CHECK FEASIBILITY CONSIDERING ALL CONSTRAINTS
C     ==================================================================

 400  continue

      if ( iprintout .ge. 1 ) then
          write(* ,8020) cnorm
          write(10,8020) cnorm
      end if

      if ( cnorm .gt. epsfeas ) then
          accinfo = 1

          if ( iprintout .ge. 1 ) then
              write(* ,9010)
              write(10,9010)
          end if

          go to 500
      end if

C     ==================================================================
C     CHECK LAGRANGE MULTIPLIERS SIGNAL RELATED TO INEQUALITIES AND
C     BOUND CONSTRAINTS
C     ==================================================================

      sgnvio = 0.0d0

      do i = 1,m
          if ( .not. equatn(i) ) then
              sgnvio = max( sgnvio, - lambda(i) )
          end if
      end do

      do i = m + 1,mtot
          sgnvio = max( sgnvio, - lambda(i) )
      end do

      if ( iprintout .ge. 1 ) then
          write(* ,8030) sgnvio
          write(10,8030) sgnvio
      end if

      if ( sgnvio .eq. 0.0d0 ) then
          accinfo = 0

          if ( iprintout .ge. 1 ) then
              write(* ,9000)
              write(10,9000)
          end if

          go to 500
      end if

C     TRY TO CORRECT MULTIPLIERS SIGNAL

      if ( iprintout .ge. 1 ) then
          write(* ,8040)
          write(10,8040)
      end if

      call minsq(n,t,m,equatn,nbds,lambda,constt,consti,status,msqiter,
     +inform)
      if ( inform .lt. 0 ) return

C     Compute signal violation

      sgnvio = 0.0d0

      do i = 1,m
          if ( .not. equatn(i) ) then
              sgnvio = max( sgnvio, - lambda(i) )
          end if
      end do

      do i = m + 1,mtot
         sgnvio = max( sgnvio, - lambda(i) )
      end do

C     Compute optimality

      do i = 1,n
          nl(i) = t(i)
      end do

      do i = n + 1,ntot
          nl(i) = 0.0d0
      end do

      do j = 1,mtot
          do i = jcsta(j),jcsta(j) + jclen(j) - 1
              nl(jcvar(i)) = nl(jcvar(i)) + lambda(j) * jcval(i)
          end do
      end do

      nlnorm = 0.0d0
      do i = 1,ntot
          nlnorm = max( nlnorm, abs( nl(i) ) )
      end do

      if ( iprintout .ge. 1 ) then
          write(* ,8050) sgnvio,nlnorm
          write(10,8050) sgnvio,nlnorm
      end if

      if ( nlnorm .le. epsopt ) then
          accinfo = 0

          if ( iprintout .ge. 1 ) then
              write(* ,9000)
              write(10,9000)
          end if

          go to 500

      else
          accinfo = 2

          if ( iprintout .ge. 1 ) then
              write(* ,9020)
              write(10,9020)
          end if

          go to 500
      end if

C     ==================================================================
C     SET SOLUTION
C     ==================================================================

 500  continue

      do i = 1,n
          xo(i) = x(i)
      end do

      do j = 1,m
          lambdao(j) = lambda(j)
      end do

C     ==================================================================
C     NON-EXECUTABLE STATEMENTS
C     ==================================================================

 8000 format(/,' NEWTON-KKT scheme in action!')
 8010 format(/,' NEWTON-KKT Iteration',42X,' = ',5X,I6,
     +       /,' Objective function value',38X,' = ',1PD11.4,
     +       /,' Maximal violation of selected nearly-active',
     +         ' constraints',7X,' = ',1PD11.4,
     +       /,' Sup-norm of the gradient of the Lagrangian',20X,' = ',
     +           1PD11.4)
c    +       /,' Sup-norm of the gradient of the Lagrangian',8X,1PD11.4,
c    +           1X,' = ',1PD11.4)
 8020 format(/,' Maximal violation of constraints',30X,' = ',1PD11.4)
 8030 format(/,' Maximal violation of Lagrange multipliers',
     +         ' non-negativity',6X,' = ',1PD11.4)
 8040 format(/,' GENCAN is being called to find the right',
     +         ' multipliers.')
 8050 format(/,' Maximal violation of Lagrange multipliers',
     +         ' non-negativity',6X,' = ',1PD11.4,
     +       /,' Sup-norm of the gradient of the Lagrangian',20X,' = ',
     +           1PD11.4)

 8080 format(/,' Singular Jacobian.',
     +         ' epsadd was increased to ',1PD11.4)
 8090 format(/,' Wrong Jacobian inertia. ',
     +       /,' Desired POS = ',I7,' NEG = ',I7,
     +       /,' Actual  POS = ',I7,' NEG = ',I7,
     +       /,' epsadd was increased to ',1PD11.4)

 9000 format(/,' Flag of NEWTON-KKT = KKT system solved!')
 9010 format(/,' Flag of NEWTON-KKT = Ignored constraints were',
     +         ' violated.')
 9020 format(/,' Flag of NEWTON-KKT = After correcting the Lagrange',
     +         ' multipliers signal,',/,' optimality was lost.')
 9030 format(/,' Flag of NEWTON-KKT = Maximum of iterations reached.')
 9040 format(/,' Flag of NEWTON-KKT = Newton can not make further',
     +         ' progress.')
 9050 format(/,' Flag of NEWTON-KKT = Singular Jacobian.')

      end

C     ******************************************************************
C     ******************************************************************

      subroutine minsq(n,t,m,equatn,nbds,lambda,constt,consti,status,
     +iter,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,iter,m,n,nbds

C     ARRAY ARGUMENTS
      character constt(nbds),status(n)
      logical equatn(m)
      integer consti(nbds)
      double precision t(n),lambda(m+nbds)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      character * 6 hptype
      character * 2 innslvr
      logical ccoded,fccoded,fcoded,gcoded,gjaccoded,innercall,jaccoded,
     +        hcoded,hccoded,hlcoded,hlpcoded,firstde,truehl,ignoref,
     +        skipacc,sclsys,useustp,safemode

C     COMMON BLOCKS
      common /algparam/ fcoded,gcoded,hcoded,ccoded,jaccoded,hccoded,
     +                  hlcoded,hlpcoded,fccoded,gjaccoded,firstde,
     +                  truehl,ignoref,skipacc,sclsys,innercall,useustp,
     +                  innslvr,hptype,safemode
      save   /algparam/
C     COMMON SCALARS
      logical constrc,gotc

C     COMMON ARRAYS
      integer jcvar(jcnnzmax),jcsta(mmax),jclen(mmax)
      double precision c(mmax),dpdc(mmax),g(nmax),gparc(nmax),
     +        jcval(jcnnzmax)

C     COMMON BLOCKS
      common /gdata/ g,gparc,c,dpdc,jcval,jcvar,jcsta,jclen,constrc,gotc
      save   /gdata/
C     COMMON SCALARS
      integer hnnz

C     COMMON ARRAYS
      integer hcol(hnnzmax),hlin(hnnzmax)
      double precision hval(hnnzmax)

C     COMMON BLOCKS
      common /hdata/ hval,hlin,hcol,hnnz
      save   /hdata/

C     The problem to be solved is
C
C         min 0.5 || b + A^T lambda ||_2^2
C
C         subject to
C
C         lambda_i >= 0, i = m+1,...,m+nabds.
C
C     Columns a_i of A^T are multiplied by
C
C         an_i = 1 / max( 1, ||a_i||_infty ).
C
C     So, if we define D = diag(an_1,...,an_{m+nabds}), the problem
C     can be rewrittem as
C
C         min 0.5 || b + A^T D D^{-1} lambda ||_2^2
C
C         subject to
C
C         an_i lambda_i >= 0, i = m+1,...,m+nabds.
C
C     Subtituting an_i lambda_i by lambda_i the problem to be solved
C     becomes
C
C         min 0.5 || b + A^T D lambda ||_2^2
C
C         subject to
C
C         lambda_i >= 0, i = m+1,...,m+nabds.

C     PARAMETERS
      integer mtotmax,ntotmax
      parameter ( mtotmax  = mmax + 2 * nmax )
      parameter ( ntotmax  = mmax + 3 * nmax )

C     COMMON SCALARS
      integer ncols,nrows

C     COMMON ARRAYS
      double precision b(nmax)

C     LOCAL SCALARS
      character * 2 innslvrtmp
      logical dum2,dum3,useustptmp
      integer cind,geninfo,i,j,k,maxit,nabds,vind
      double precision dum1,dum4,dum5,dum6,eps,msqf,msqnlpsupn

C     LOCAL ARRAYS
      integer ind(mtotmax)
      double precision l(mtotmax),msqnl(mtotmax),scol(mtotmax),
     +        u(mtotmax),x(mtotmax)

C     COMMON BLOCKS
      common /prodat/ b,ncols,nrows

C     RHS

      do i = 1,n
          b(i) = t(i)
      end do

C     Matrix

      hnnz = 0

      do j = 1,m
          ind(j) = j

          do i = jcsta(j),jcsta(j) + jclen(j) - 1
              if ( jcvar(i) .le. n ) then
                  hnnz = hnnz + 1
                  hcol(hnnz) = j
                  hlin(hnnz) = jcvar(i)
                  hval(hnnz) = jcval(i)
              end if
          end do

          x(j) = lambda(j)
          if ( .not. equatn(j) ) then
             l(j) =   0.0d0
          else 
             l(j) = - 1.0d+20
          end if
          u(j) =   1.0d+20
      end do

      nabds = 0
      do j = 1,nbds
          cind = m + j
          vind = consti(j)

          if ( constt(j) .eq. status(vind) ) then
              nabds = nabds + 1
              k = m + nabds

              ind(k) = cind

              do i = jcsta(cind),jcsta(cind) + jclen(cind) - 1
                  if ( jcvar(i) .le. n ) then
                      hnnz = hnnz + 1
                      hcol(hnnz) = k
                      hlin(hnnz) = jcvar(i)
                      hval(hnnz) = jcval(i)
                  end if
              end do

              x(k) = lambda(cind)
              l(k) = 0.0d0
              u(k) = 1.0d+20
          end if
      end do

C     Dimensions

      nrows = n
      ncols = m + nabds

C     Columns scaling

      do j = 1,ncols
          scol(j) = 1.0d0
      end do

      do i = 1,hnnz
          scol(hcol(i)) = max( scol(hcol(i)), abs( hval(i) ) )
      end do

      do j = 1,ncols
          scol(j) = 1.0d0 / scol(j)
      end do

      do i = 1,hnnz
          hval(i) = hval(i) * scol(hcol(i))
      end do

      do i = 1,ncols
          x(i) = x(i) / scol(i)
      end do

C     Call the solver

      innercall = .true.

      innslvrtmp = innslvr
      useustptmp = useustp

      innslvr = 'TN'
      useustp = .true.

      eps   = 1.0d-16
      maxit = 200

      call gencan(ncols,x,l,u,0,dum1,dum2,dum3,dum4,0.0d0,eps,
     +maxit,iter,msqf,msqnl,msqnlpsupn,dum5,dum6,geninfo,inform)

      innercall = .false.

      innslvr = innslvrtmp
      useustp = useustptmp

C     Copy unscaled solution to lambda

      do i = 1,ncols
          lambda(ind(i)) = x(i) * scol(i)
      end do

      end

C     ******************************************************************
C     ******************************************************************

      subroutine minsqf(n,x,f,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,n
      double precision f

C     ARRAY ARGUMENTS
      double precision x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      integer hnnz

C     COMMON ARRAYS
      integer hcol(hnnzmax),hlin(hnnzmax)
      double precision hval(hnnzmax)

C     COMMON BLOCKS
      common /hdata/ hval,hlin,hcol,hnnz
      save   /hdata/

C     COMMON SCALARS
      integer ncols,nrows

C     COMMON ARRAYS
      double precision b(nmax)

C     LOCAL SCALARS
      integer i

C     LOCAL ARRAYS
      double precision p(nmax)

C     COMMON BLOCKS
      common /prodat/ b,ncols,nrows

      do i = 1,nrows
          p(i) = b(i)
      end do

      do i = 1,hnnz
          p(hlin(i)) = p(hlin(i)) + x(hcol(i)) * hval(i)
      end do

      f = 0.0d0
      do i = 1,nrows
          f = f + p(i) ** 2
      end do

      f = 0.5d0 * f

      f = 1.0d+08 * f

      end

C     ******************************************************************
C     ******************************************************************

      subroutine minsqg(n,x,g,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,n

C     ARRAY ARGUMENTS
      double precision g(n),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      integer hnnz

C     COMMON ARRAYS
      integer hcol(hnnzmax),hlin(hnnzmax)
      double precision hval(hnnzmax)

C     COMMON BLOCKS
      common /hdata/ hval,hlin,hcol,hnnz
      save   /hdata/

C     COMMON SCALARS
      integer ncols,nrows

C     COMMON ARRAYS
      double precision b(nmax)

C     LOCAL SCALARS
      integer i

C     LOCAL ARRAYS
      double precision p(nmax)

C     COMMON BLOCKS
      common /prodat/ b,ncols,nrows

      do i = 1,nrows
          p(i) = b(i)
      end do

      do i = 1,hnnz
          p(hlin(i)) = p(hlin(i)) + x(hcol(i)) * hval(i)
      end do

      do i = 1,ncols
          g(i) = 0.0d0
      end do

      do i = 1,hnnz
          g(hcol(i)) = g(hcol(i)) + p(hlin(i)) * hval(i)
      end do

      do i = 1,ncols
          g(i) = 1.0d+08 * g(i)
      end do

      end

C     ******************************************************************
C     ******************************************************************

      subroutine minsqhp(n,x,p,hp,goth,inform)

      implicit none

C     SCALAR ARGUMENTS
      logical goth
      integer inform,n

C     ARRAY ARGUMENTS
      double precision hp(n),p(n),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      integer hnnz

C     COMMON ARRAYS
      integer hcol(hnnzmax),hlin(hnnzmax)
      double precision hval(hnnzmax)

C     COMMON BLOCKS
      common /hdata/ hval,hlin,hcol,hnnz
      save   /hdata/

C     COMMON SCALARS
      integer ncols,nrows

C     COMMON ARRAYS
      double precision b(nmax)

C     LOCAL SCALARS
      integer i

C     LOCAL ARRAYS
      double precision tmp(nmax)

C     COMMON BLOCKS
      common /prodat/ b,ncols,nrows

      do i = 1,nrows
          tmp(i) = 0.0d0
      end do

      do i = 1,hnnz
          tmp(hlin(i)) = tmp(hlin(i)) + p(hcol(i)) * hval(i)
      end do

      do i = 1,ncols
          hp(i) = 0.0d0
      end do

      do i = 1,hnnz
          hp(hcol(i)) = hp(hcol(i)) + tmp(hlin(i)) * hval(i)
      end do

      do i = 1,ncols
          hp(i) = 1.0d+08 * hp(i)
      end do

      end

C     ******************************************************************
C     ******************************************************************

      logical function minsqstop(n,x,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,n

C     ARRAY ARGUMENTS
      double precision x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      double precision bignum,macheps,macheps12,macheps13,macheps23

C     COMMON BLOCKS
      common /machcon/ bignum,macheps,macheps12,macheps13,macheps23
      save   /machcon/
C     COMMON SCALARS
      integer hnnz

C     COMMON ARRAYS
      integer hcol(hnnzmax),hlin(hnnzmax)
      double precision hval(hnnzmax)

C     COMMON BLOCKS
      common /hdata/ hval,hlin,hcol,hnnz
      save   /hdata/

C     COMMON SCALARS
      integer ncols,nrows

C     COMMON ARRAYS
      double precision b(nmax)

C     LOCAL SCALARS
      integer i
      double precision pnorm

C     LOCAL ARRAYS
      double precision p(nmax)

C     COMMON BLOCKS
      common /prodat/ b,ncols,nrows

      do i = 1,nrows
          p(i) = b(i)
      end do

      do i = 1,hnnz
          p(hlin(i)) = p(hlin(i)) + x(hcol(i)) * hval(i)
      end do

      pnorm = 0.0d0
      do i = 1,nrows
          pnorm = max( pnorm, abs( p(i) ) )
      end do

      minsqstop = .false.
      if ( pnorm .le. macheps12 ) then
          minsqstop = .true.
      end if

      end
C     ******************************************************************
C     ******************************************************************
      subroutine fparam(epsfeas,epsopt,iprint,ncomp)

      implicit none

C     SCALAR ARGUMENTS
      integer ncomp,iprint
      double precision epsfeas,epsopt

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      character * 6 hptype
      character * 2 innslvr
      logical ccoded,fccoded,fcoded,gcoded,gjaccoded,innercall,jaccoded,
     +        hcoded,hccoded,hlcoded,hlpcoded,firstde,truehl,ignoref,
     +        skipacc,sclsys,useustp,safemode

C     COMMON BLOCKS
      common /algparam/ fcoded,gcoded,hcoded,ccoded,jaccoded,hccoded,
     +                  hlcoded,hlpcoded,fccoded,gjaccoded,firstde,
     +                  truehl,ignoref,skipacc,sclsys,innercall,useustp,
     +                  innslvr,hptype,safemode
      save   /algparam/
C     COMMON SCALARS
      logical iprintctl(7)
      integer iprintinn,iprintout,mprint,nprint

C     COMMON BLOCKS
      common /outdat/ iprintctl,iprintinn,iprintout,nprint,mprint
      save   /outdat/

C     COMMON SCALARS
      logical rmfixv,yset

C     COMMON ARRAYS
      integer ycor(nmax),yind(0:nmax)
      double precision y(nmax)

C     COMMON BLOCKS
      common /fixvar/ y,ycor,yind,yset,rmfixv
      save   /fixvar/
C     COMMON SCALARS
      logical slacks
      integer nws

C     COMMON ARRAYS
      integer slaind(mmax)

C     COMMON BLOCKS
      common /sladat/ slaind,nws,slacks
      save   /sladat/
C     COMMON SCALARS
      logical scale
      double precision sf,usf

C     COMMON ARRAYS
      double precision sc(mmax),usc(mmax)

C     COMMON BLOCK
      common /scadat/ sc,usc,sf,usf,scale
      save   /scadat/

C     PARAMETERS
      integer nwords
      parameter ( nwords = 16 )

C     LOCAL SCALARS
      logical lss,scl
      integer i,ifirst,ikey,ilast,inum,j
      double precision dnum

C     LOCAL ARRAYS
      character * 80 line
      character * 10 keyword
      character *  4 lsssub,lssdes,sclsub,scldes

C     DATA BLOCKS
      character * 1  addinfo(nwords),lower(26),upper(26)
      character * 10 dictionary(nwords)
      character * 41 description(nwords)

      data lower /'a','b','c','d','e','f','g','h','i','j','k','l','m',
     +            'n','o','p','q','r','s','t','u','v','w','x','y','z'/
      data upper /'A','B','C','D','E','F','G','H','I','J','K','L','M',
     +            'N','O','P','Q','R','S','T','U','V','W','X','Y','Z'/

      data dictionary( 1) /'INCREMENTA'/
      data dictionary( 2) /'HESSIAN-AP'/
      data dictionary( 3) /'TRUE-HESSI'/
      data dictionary( 4) /'SKIP-ACCEL'/
      data dictionary( 5) /'TRUST-REGI'/
      data dictionary( 6) /'NEWTON-LIN'/
      data dictionary( 7) /'TRUNCATED-'/
      data dictionary( 8) /'LINEAR-SYS'/
      data dictionary( 9) /'FIXED-VARI'/
      data dictionary(10) /'ADD-SLACKS'/
      data dictionary(11) /'OBJECTIVE-'/
      data dictionary(12) /'IGNORE-OBJ'/
      data dictionary(13) /'FEASIBILIT'/
      data dictionary(14) /'OPTIMALITY'/
      data dictionary(15) /'OUTPUT-DET'/
      data dictionary(16) /'NCOMP-ARRA'/

      data description( 1) /'INCREMENTAL-QUOTIENTS-IN-CG              '/
      data description( 2) /'HESSIAN-APPROXIMATION-IN-CG              '/
      data description( 3) /'TRUE-HESSIAN-PRODUCT-IN-CG               '/
      data description( 4) /'SKIP-ACCELERATION-STEP                   '/
      data description( 5) /'TRUST-REGIONS-INNER-SOLVER               '/
      data description( 6) /'NEWTON-LINE-SEARCH-INNER-SOLVER          '/
      data description( 7) /'TRUNCATED-NEWTON-LINE-SEARCH-INNER-SOLVER'/
      data description( 8) /'LINEAR-SYSTEMS-SCALING-AVOIDED           '/
      data description( 9) /'FIXED-VARIABLES-REMOVAL-AVOIDED          '/
      data description(10) /'ADD-SLACKS                               '/
      data description(11) /'OBJECTIVE-AND-CONSTRAINTS-SCALING-AVOIDED'/
      data description(12) /'IGNORE-OBJECTIVE-FUNCTION                '/
      data description(13) /'FEASIBILITY-TOLERANCE                    '/
      data description(14) /'OPTIMALITY-TOLERANCE                     '/
      data description(15) /'OUTPUT-DETAIL                            '/
      data description(16) /'NCOMP-ARRAY                              '/

      data addinfo( 1) /' '/
      data addinfo( 2) /' '/
      data addinfo( 3) /' '/
      data addinfo( 4) /' '/
      data addinfo( 5) /' '/
      data addinfo( 6) /' '/
      data addinfo( 7) /' '/
      data addinfo( 8) /' '/
      data addinfo( 9) /' '/
      data addinfo(10) /' '/
      data addinfo(11) /' '/
      data addinfo(12) /' '/
      data addinfo(13) /'D'/
      data addinfo(14) /'D'/
      data addinfo(15) /'I'/
      data addinfo(16) /'I'/

C     EXTERNAL FUNCTIONS
      external lss,scl

C     INITIALIZATION
      if ( lss(lsssub) ) then
          lssdes = lsssub
          if ( lsssub .eq. 'MA57' ) then
              scldes = lsssub
          else
              if ( scl(sclsub) ) then
                  scldes = sclsub
              else
                  scldes = 'NONE'
              end if
          end if
      else
          lssdes = 'NONE'
          scldes = 'NONE'
      end if

C     BANNER
      if ( iprintctl(1) ) then
          write(*, 8000)
          write(10,8000)
      end if

C     OPENING THE SPECIFICATION FILE
      open(20,err=300,file='algencan.dat',status='old')

      if ( iprintctl(2) ) then
          write(*, 9005)
          write(10,9005)
      end if

C     MAIN LOOP

 100  continue

C     READING LINES
      read(20,fmt=1000,err=400,end=200) line

C     PROCESS LINES

C     Find first character
      i = 1
 110  if ( i .le. 80 .and. line(i:i) .eq. ' ' ) then
          i = i + 1
          go to 110
      end if

C     Skip blank lines
      if ( i .gt. 80 ) then
          go to 100
      end if

      ifirst = i

C     Skip comments
      if ( line(ifirst:ifirst) .eq. '*' .or.
     +     line(ifirst:ifirst) .eq. '#' ) then
          go to 100
      end if

C     Find the end of the keyword
      i = ifirst + 1
 120  if ( i .le. 80 .and. line(i:i) .ne. ' ' ) then
          i = i + 1
          go to 120
      end if

      ilast = i - 1

C     Obtain the first 10 characters and convert to upper-case
      keyword = '          '
      do i = 1,min( 10, ilast - ifirst + 1 )
          keyword(i:i) = line(ifirst+i-1:ifirst+i-1)
          do j = 1,26
              if ( keyword(i:i) .eq. lower(j) ) then
                  keyword(i:i) = upper(j)
              end if
          end do
      end do

C     Look up the keyword in the dictionary
      i = 1
 130  if ( i .le. nwords .and. keyword .ne. dictionary(i) ) then
          i = i + 1
          go to 130
      end if

C     Ignore unknown keywords
      if ( i .gt. nwords ) then
          if ( iprintctl(2) ) then
              write(*, 9020) line(ifirst:ilast)
              write(10,9020) line(ifirst:ilast)
          end if
          go to 100
      end if

      ikey = i

C     Read additional information if needed
      if ( addinfo(ikey) .ne. ' ' ) then

C         Skip blanks
          i = ilast + 1
 140      if ( i .le. 80 .and. line(i:i) .eq. ' ' ) then
              i = i + 1
              go to 140
          end if

C         Ignore keywords without the required information
          if ( i .gt. 80 ) then
              if ( iprintctl(2) ) then
                  write(*, 9030) description(ikey)
                  write(10,9030) description(ikey)
              end if
              go to 100
          end if

C         Read additional information
          if ( addinfo(ikey) .eq. 'I' ) then
              read(unit=line(i:80),fmt=2000) inum

          else if ( addinfo(ikey) .eq. 'D' ) then
              read(unit=line(i:80),fmt=3000) dnum
          end if

      end if

C     Process keyword
      if ( iprintctl(2) ) then
          if ( addinfo(ikey) .eq. ' ' ) then
              write(*, 9040) description(ikey)
              write(10,9040) description(ikey)
          else if ( addinfo(ikey) .eq. 'I' ) then
              write(*, 9041) description(ikey),inum
              write(10,9041) description(ikey),inum
          else if ( addinfo(ikey) .eq. 'D' ) then
              write(*, 9042) description(ikey),dnum
              write(10,9042) description(ikey),dnum
          end if
      end if

C     Set the corresponding algencan argument
      if ( ikey .eq.  1 ) then
          hptype = 'INCQUO'

      else if ( ikey .eq.  2 ) then
          hptype = 'HAPPRO'

      else if ( ikey .eq.  3 ) then
          if ( hlpcoded .or. truehl ) then
              hptype = 'TRUEHP'
          else
              if ( iprintctl(2) ) then
                  write(* ,9100) description(ikey)
                  write(10,9100) description(ikey)
              end if
          end if

      else if ( ikey .eq.  4 ) then
          skipacc = .true.

      else if ( ikey .eq.  5 ) then
          if ( .not. truehl ) then
              if ( iprintctl(2) ) then
                  write(* ,9110) description(ikey)
                  write(10,9110) description(ikey)
              end if
          else if ( .not. lss(lsssub) ) then
              if ( iprintctl(2) ) then
                  write(* ,9120) description(ikey)
                  write(10,9120) description(ikey)
              end if
          else
              innslvr = 'TR'
          end if

      else if ( ikey .eq.  6 ) then
          if ( .not. truehl ) then
              if ( iprintctl(2) ) then
                  write(* ,9110) description(ikey)
                  write(10,9110) description(ikey)
              end if
          else if ( .not. lss(lsssub) ) then
              if ( iprintctl(2) ) then
                  write(* ,9120) description(ikey)
                  write(10,9120) description(ikey)
              end if
          else
              innslvr = 'NW'
          end if

      else if ( ikey .eq.  7 ) then
          innslvr = 'TN'

      else if ( ikey .eq.  8 ) then
          if ( lss(lsssub) ) then
              sclsys = .false.

          else
              if ( iprintctl(2) ) then
                  write(* ,9130) description(ikey)
                  write(10,9130) description(ikey)
              end if
          end if

      else if ( ikey .eq.  9 ) then
          rmfixv = .false.

      else if ( ikey .eq. 10 ) then
          slacks = .true.

      else if ( ikey .eq. 11 ) then
          scale = .false.

      else if ( ikey .eq. 12 ) then
          ignoref = .true.
          scale   = .false.

      else if ( ikey .eq. 13 ) then
          epsfeas = dnum

      else if ( ikey .eq. 14 ) then
          epsopt = dnum

      else if ( ikey .eq. 15 ) then
          iprint = inum

      else if ( ikey .eq. 16 ) then
          ncomp = inum
      end if

C     IIERATE
      go to 100

C     END OF LOOP

C     TERMINATIONS

C     CLOSING SPECIFICATION FILE
 200  continue
      close(20)
      go to 500

C     NO SPECIFICATION FILE
 300  continue
      if ( iprintctl(2) ) then
          write(*, 9000)
          write(10,9000)
      end if
      go to 500

C     ERROR READING THE SPECIFICATION FILE
 400  continue
      if ( iprintctl(2) ) then
          write(*, 9010)
          write(10,9010)
      end if
      go to 500

C     PRINTING PARAMETERS VALUES
 500  continue
      if ( iprintctl(2) ) then
          write(* ,4000) firstde,hptype,innslvr,sclsys,skipacc,lssdes,
     +                   scldes,rmfixv,slacks,scale,epsfeas,epsopt,
     +                   iprint,ncomp
          write(10,4000) firstde,hptype,innslvr,sclsys,skipacc,lssdes,
     +                   scldes,rmfixv,slacks,scale,epsfeas,epsopt,
     +                   iprint,ncomp
      end if

C     NON-EXECUTABLE STATEMENTS

 1000 format(A80)
 2000 format(BN,I20)
 3000 format(BN,F24.0)
 4000 format(/,1X,'ALGENCAN PARAMETERS:',
     +       /,1X,'firstde  = ',     19X,L1,
     +       /,1X,'hptype   = ',     14X,A6,
     +       /,1X,'innslvr  = ',     18X,A2,
     +       /,1X,'sclsys   = ',     19X,L1,
     +       /,1X,'skipacc  = ',     19X,L1,
     +       /,1X,'lsssub   = ',     16X,A4,
     +       /,1X,'sclsub   = ',     16X,A4,
     +       /,1X,'rmfixv   = ',     19X,L1,
     +       /,1X,'slacks   = ',     19X,L1,
     +       /,1X,'scale    = ',     19X,L1,
     +       /,1X,'epsfeas  = ',8X,1P,D12.4,
     +       /,1X,'epsopt   = ',8X,1P,D12.4,
     +       /,1X,'iprint   = ',        I20,
     +       /,1X,'ncomp    = ',        I20)
 8000 format(/,1X,78('='),
     +       /,1X,'This is ALGENCAN 2.3.7.',
     +       /,1X,'ALGENCAN, an augmented Lagrangian method for ',
     +            'nonlinear programming, is part of',/,1X,'the TANGO ',
     +            'Project: Trustable Algorithms for Nonlinear ',
     +            'General Optimization.',/,1X,'See ',
     +            'http://www.ime.usp.br/~egbirgin/tango/ for details.',
     +       /,1X,78('='))
 9000 format(/,1X,'The optional specification file algencan.dat was ',
     +            'not found in the current',/,1X,'directory (this is ',
     +            'not a problem nor an error). The default values ',
     +            'for the',/,1X,'ALGENCAN parameters will be used.')
 9005 format(/,1X,'Specification file algencan.dat is being used.')
 9010 format(/,1X,'Error reading specification file algencan.dat.')
 9020 format(  1X,'Ignoring unknown keyword ',A41)
 9030 format(  1X,'Ignoring incomplete keyword ',A41)
 9040 format(1X,A41)
 9041 format(1X,A41,5X,I20)
 9042 format(1X,A41,1X,1P,D24.8)

 9100 format(/,1X,'Warning: Ignoring keyword ',A41,'.',
     +       /,1X,'This option requires subroutines EVALH and EVALHC, ',
     +            'or, alternatively,',/,1X,'subroutine EVALHLP, to ',
     +            'be coded by the user. If you already coded them,',
     +       /,1X,'set array CODED in subrutine INIP appropiately.',/)
 9110 format(/,1X,'Warning: Ignoring keyword ',A41,'.',
     +       /,1X,'This option requires subroutines EVALH and EVALHC, ',
     +            'or, alternatively,',/,1X,'subroutine EVALHL, to ',
     +            'be coded by the user. If you already coded them,',
     +       /,1X,'set array CODED in subrutine INIP appropiately.',/)
 9120 format(/,1X,'Warning: Ignoring keyword ',A41,'.',
     +       /,1X,'This option requires subroutine MA27 or MA57 from ',
     +            'HSL to be provided by the',/,1X,'user. If you ',
     +            'have any of them, see the compilation instructions ',
     +            'for details.',/)
 9130 format(/,1X,'Warning: Ignoring keyword ',A41,'.',
     +       /,1X,'This option applies only to the case in which ',
     +            'subroutines MA27 or MA57 from HSL are being used ',
     +            'to solve linear systems. If linear systems are ',
     +            'being solved and scaled, either the embedded ',
     +            'scaling option of MA57 or one of the subroutines ',
     +            'MC30 or MC77 from HSL would be used in conjuction ',
     +            'with MA27.')

      end
C     *****************************************************************
C     *****************************************************************

      subroutine checkd(n,l,u,m,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,m,n

C     ARRAY ARGUMENTS
      double precision l(n),u(n)

C     This subrotutine checks the user supplied first and second
C     derivatives subroutines (evalg, evalh, evaljac and evalhc) for
C     computing the objective function gradient and Hessian and the
C     constraints gradients and Hessians, respectively.

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      character * 6 hptype
      character * 2 innslvr
      logical ccoded,fccoded,fcoded,gcoded,gjaccoded,innercall,jaccoded,
     +        hcoded,hccoded,hlcoded,hlpcoded,firstde,truehl,ignoref,
     +        skipacc,sclsys,useustp,safemode

C     COMMON BLOCKS
      common /algparam/ fcoded,gcoded,hcoded,ccoded,jaccoded,hccoded,
     +                  hlcoded,hlpcoded,fccoded,gjaccoded,firstde,
     +                  truehl,ignoref,skipacc,sclsys,innercall,useustp,
     +                  innslvr,hptype,safemode
      save   /algparam/

C     LOCAL SCALARS
      character answer
      integer i,j
      double precision drand,seed,smalll,smallu

C     LOCAL ARRAYS
      double precision x(nmax)

C     EXTERNAL FUNCTIONS
      external drand

      call vunsetp()

C     SET A RANDOM POINT

      seed = 123456.0d0
      do i = 1,n
          smalll = max( l(i), - 10.0d0 )
          smallu = min( u(i),   10.0d0 )
          if ( .not. smalll .lt. smallu ) then
              smalll = l(i)
              smallu = u(i)
          end if
          x(i) = smalll + ( smallu - smalll ) * drand(seed)
      end do

      write(* ,100)
      write(10,100)

      do i = 1,n
          write(* ,110) i,x(i)
          write(10,110) i,x(i)
      end do

C     CHECK OBJECTIVE FUNCTION GRADIENT

      if ( .not. gcoded ) then
          write(* ,120) 'evalg'
          write(10,120) 'evalg'

          go to 1000
      end if

      write(* ,130) 'evalg'
      write(10,130) 'evalg'

      read(*,*) answer

      if ( answer .eq. 'A' .or. answer .eq. 'a' ) then
          return

      else if ( answer .eq. 'S' .or. answer .eq. 's' ) then
          go to 1000

      else if ( answer .eq. 'Y' .or. answer .eq. 'y' ) then
          call checkg(n,x,inform)
          if ( inform .lt. 0 ) return
      end if

C     CHECK JACOBIAN OF CONSTRAINTS

 1000 continue

      if ( .not. jaccoded ) then
          write(* ,120) 'evaljac'
          write(10,120) 'evaljac'

          go to 1020
      end if

      write(* ,130) 'evaljac'
      write(10,130) 'evaljac'

      read(*,*) answer

      if ( answer .eq. 'A' .or. answer .eq. 'a' ) then
          return

      else if ( answer .eq. 'S' .or. answer .eq. 's' ) then
          go to 1020

      else if ( answer .eq. 'Y' .or. answer .eq. 'y' ) then

          j = 1

 1010     if ( j .le. m ) then

              write(* ,220) j
              write(10,220) j

              read(*,*) answer

              if ( answer .eq. 'A' .or. answer .eq. 'a' ) then
                  return

              else if ( answer .eq. 'S' .or. answer .eq. 's' ) then
                  go to 1020

              else if ( answer .eq. 'Y' .or. answer .eq. 'y' ) then
                  call checkjac(n,x,j,inform)
                  if ( inform .lt. 0 ) return
              end if

              j = j + 1

              go to 1010

          end if

      end if

C     CHECK HESSIAN OF THE OBJECTIVE FUNCTION

 1020 continue

      if ( .not. hcoded ) then
          write(* ,120) 'evalh'
          write(10,120) 'evalh'

          go to 1030
      end if

      write(* ,130) 'evalh'
      write(10,130) 'evalh'

      read(*,*) answer

      if ( answer .eq. 'A' .or. answer .eq. 'a' ) then
          return

      else if ( answer .eq. 'S' .or. answer .eq. 's' ) then
          go to 1030

      else if ( answer .eq. 'Y' .or. answer .eq. 'y' ) then
          call checkh(n,x,inform)
          if ( inform .lt. 0 ) return
      end if

C     CHECK HESSIANS OF THE CONSTRAINTS

 1030 continue

      if ( .not. hccoded ) then
          write(* ,120) 'evalhc'
          write(10,120) 'evalhc'

          go to 1050
      end if

      write(* ,130) 'evalhc'
      write(10,130) 'evalhc'

      read(*,*) answer

      if ( answer .eq. 'A' .or. answer .eq. 'a' ) then
          return

      else if ( answer .eq. 'S' .or. answer .eq. 's' ) then
          go to 1050

      else if ( answer .eq. 'Y' .or. answer .eq. 'y' ) then

          j = 1

 1040     if ( j .le. m ) then

              write(* ,230) j
              write(10,230) j

              read(*,*) answer

              if ( answer .eq. 'A' .or. answer .eq. 'a' ) then
                  return

              else if ( answer .eq. 'S' .or. answer .eq. 's' ) then
                  go to 1050

              else if ( answer .eq. 'Y' .or. answer .eq. 'y' ) then
                  call checkhc(n,x,j,inform)
                  if ( inform .lt. 0 ) return
              end if

              j = j + 1

              go to 1040

          end if

      end if

C     CHECK GRADIENT OF OBJECTIVE FUNCTION PLUS JACOBIAN OF CONSTRAINTS

 1050 continue

      if ( .not. gjaccoded ) then
          write(* ,120) 'evalgjac'
          write(10,120) 'evalgjac'

          go to 1060
      end if

      write(* ,130) 'evalgjac'
      write(10,130) 'evalgjac'

      read(*,*) answer

      if ( answer .eq. 'A' .or. answer .eq. 'a' ) then
          return

      else if ( answer .eq. 'S' .or. answer .eq. 's' ) then
          go to 1060

      else if ( answer .eq. 'Y' .or. answer .eq. 'y' ) then
          call checkgjac(n,m,x,inform)
          if ( inform .lt. 0 ) return
      end if

C     CHECK HESSIAN OF THE LAGRANGIAN

 1060 continue

      if ( .not. hlcoded ) then
          write(* ,120) 'evalhl'
          write(10,120) 'evalhl'

          go to 1070
      end if

      write(* ,130) 'evalhl'
      write(10,130) 'evalhl'

      read(*,*) answer

      if ( answer .eq. 'A' .or. answer .eq. 'a' ) then
          return

      else if ( answer .eq. 'S' .or. answer .eq. 's' ) then
          go to 1070

      else if ( answer .eq. 'Y' .or. answer .eq. 'y' ) then
          write(* ,*) 'Test of evalhl not implemented yet!'
          write(10,*) 'Test of evalhl not implemented yet!'
      end if

C     CHECK HESSIAN OF THE LAGRANGIAN TIMES A VECTOR

 1070 continue

      if ( .not. hlpcoded ) then
          write(* ,120) 'evalhlp'
          write(10,120) 'evalhlp'

          go to 1080
      end if

      write(* ,130) 'evalhlp'
      write(10,130) 'evalhlp'

      read(*,*) answer

      if ( answer .eq. 'A' .or. answer .eq. 'a' ) then
          return

      else if ( answer .eq. 'S' .or. answer .eq. 's' ) then
          go to 1080

      else if ( answer .eq. 'Y' .or. answer .eq. 'y' ) then
          write(* ,*) 'Test of evalhlp not implemented yet!'
          write(10,*) 'Test of evalhlp not implemented yet!'
      end if

C     NON-EXECUTABLE STATEMENTS

 1080 continue

 100  format(/,1X,'Derivatives will be tested at the random point: ')
 110  format(  1X,'x(',I6,') = ',1P,D15.8)
 120  format(/,1X,'Skipping checking of uncoded ',A8,' subroutine.')
 130  format(/,1X,'Would you like to ckeck subroutine ',A8,'?',
     +       /,1X,'Type Y(es), N(o), A(bort checking) or ',
     +            'S(kip checking this subroutine): ')

 200  format(/,1X,'Check gradient of the objective function?',
     +       /,1X,'Type Y(es), N(o) or A(bort checking): ')
 210  format(/,1X,'Check Hessian matrix of the objective function?',
     +       /,1X,'Type Y(es), N(o) or A(bort checking): ')

 220  format(/,1X,'Check gradient of constraint ',I5,'?',
     +       /,1X,'Type Y(es), N(o), A(bort checking) or ',
     +            'S(kip gradients of constraints): ')
 230  format(/,1X,'Check Hessian matrix of constraint ',I5,'?',
     +       /,1X,'Type Y(es), N(o), A(bort checking) or ',
     +            'S(kip Hessians of constraints): ')

      end

C     *****************************************************************
C     *****************************************************************

      subroutine checkg(n,x,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,n

C     ARRAY ARGUMENTS
      double precision x(n)

C     This subrotutine checks the user supplied subroutine evalg for
C     computing the gradient of the objective function using central
C     finite differences with two different discretization steps.

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      double precision bignum,macheps,macheps12,macheps13,macheps23

C     COMMON BLOCKS
      common /machcon/ bignum,macheps,macheps12,macheps13,macheps23
      save   /machcon/

C     LOCAL SCALARS
      integer i
      double precision fminus,fplus,gdiff1,gdiff2,maxerr,step1,step2,tmp

C     LOCAL ARRAYS
      double precision g(nmax)

      call vevalg(n,x,g,inform)
      if ( inform .lt. 0 ) return

      write(* ,100)
      write(10,100)

      maxerr = 0.0d0

      do i = 1,n
          tmp  = x(i)

          step1 = macheps13 * max( abs( tmp ), 1.0d0 )

          x(i) = tmp + step1
          call vevalf(n,x,fplus,inform)
          if ( inform .lt. 0 ) return

          x(i) = tmp - step1
          call vevalf(n,x,fminus,inform)
          if ( inform .lt. 0 ) return

          gdiff1 = ( fplus - fminus ) / ( 2.0d0 * step1 )

          step2 = macheps13 * max( abs( tmp ), 1.0d-03 )

          x(i) = tmp + step2
          call vevalf(n,x,fplus,inform)
          if ( inform .lt. 0 ) return

          x(i) = tmp - step2
          call vevalf(n,x,fminus,inform)
          if ( inform .lt. 0 ) return

          x(i) = tmp

          gdiff2 = ( fplus - fminus ) / ( 2.0d0 * step2 )

          tmp = min( abs( g(i) - gdiff1 ), abs( g(i) - gdiff2 ) )

          write(* ,110) i,g(i),gdiff1,gdiff2,tmp
          write(10,110) i,g(i),gdiff1,gdiff2,tmp

          maxerr = max( maxerr, tmp )

      end do

      write(* ,120) maxerr
      write(10,120) maxerr

C     NON-EXECUTABLE STATEMENTS

 100  format(/,1X,'Gradient vector of the objective function.',
     +       /,1X,'Index',13X,'evalg',2X,'Central diff (two different ',
     +            'steps)',4X,'Absolute error')
 110  format(  1X,I5,4(3X,1P,D15.8))
 120  format(  1X,'Maximum absolute error = ',1P,D15.8)

      end

C     *****************************************************************
C     *****************************************************************

      subroutine checkh(n,x,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,n

C     ARRAY ARGUMENTS
      double precision x(n)

C     This subrotutine checks the user supplied subroutine evalh for
C     computing the Hessian of the objective function using central
C     finite differences with two different discretization steps.

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      double precision bignum,macheps,macheps12,macheps13,macheps23

C     COMMON BLOCKS
      common /machcon/ bignum,macheps,macheps12,macheps13,macheps23
      save   /machcon/

C     LOCAL SCALARS
      logical nullcol
      integer i,j,hnnz
      double precision elem,hdiff1,hdiff2,maxerr,step1,step2,tmp

C     LOCAL ARRAYS
      integer hlin(nsmax**2),hcol(nsmax**2)
      double precision g(nsmax),gplus1(nsmax),gplus2(nsmax),
     +        H(nsmax,nsmax),hval(nsmax**2),maxcoe(nsmax)

C     Check viability of the test

      if ( n .gt. nsmax ) then
          write(*, 100) nsmax,nsmax
          write(10,100) nsmax,nsmax

          return
      end if

C     Compute the gradient of the objective function at x

      call vevalg(n,x,g,inform)
      if ( inform .lt. 0 ) return

C     Compute the Hessian of the objective function at x and save in a
C     dense matrix

      call vevalh(n,x,hlin,hcol,hval,hnnz,inform)
      if ( inform .lt. 0 ) return

      do j = 1,n
          do i = 1,n
              H(i,j) = 0.0d0
          end do
      end do

      do i = 1,hnnz
          H(hlin(i),hcol(i)) = H(hlin(i),hcol(i)) + hval(i)
      end do

C     Test column by column

      write(* ,200)
      write(10,200)

      maxerr = 0.0d0

      do j = 1,n

          tmp  = x(j)

          step1 = macheps12 * max( abs( tmp ), 1.0d0 )

          x(j) = tmp + step1
          call vevalg(n,x,gplus1,inform)
          if ( inform .lt. 0 ) return

          step2 = macheps12 * max( abs( tmp ), 1.0d-03 )

          x(j) = tmp + step2
          call vevalg(n,x,gplus2,inform)
          if ( inform .lt. 0 ) return

          x(j) = tmp

          write(* ,210) j
          write(10,210) j

          maxcoe(j) = 0.0d0

          nullcol = .true.

          do i = 1,n
              if ( i .ge. j ) then
                  elem = H(i,j)
              else
                  elem = H(j,i)
              end if
              hdiff1 = ( gplus1(i) - g(i) ) / step1
              hdiff2 = ( gplus2(i) - g(i) ) / step2
              tmp = min( abs( elem - hdiff1 ), abs( elem - hdiff2 ) )
              if ( elem   .ne. 0.0d0 .or.
     +             hdiff1 .ne. 0.0d0 .or.
     +             hdiff2 .ne. 0.0d0 ) then
                  if ( nullcol ) then
                      nullcol = .false.
                      write(* ,220)
                      write(10,220)
                  end if
                  write(* ,230) i,elem,hdiff1,hdiff2,tmp
                  write(10,230) i,elem,hdiff1,hdiff2,tmp
              end if
              maxcoe(j) = max( maxcoe(j), tmp )
          end do

          maxerr = max( maxerr, maxcoe(j) )

          if ( nullcol ) then
              write(* ,240)
              write(10,240)
          else
              write(* ,250) maxcoe(j)
              write(10,250) maxcoe(j)
          end if

      end do

      write(* ,*)
      write(10,*)

      do j = 1,n
          write(* ,260) j,maxcoe(j)
          write(10,260) j,maxcoe(j)
      end do

      write(* ,270) maxerr
      write(10,270) maxerr

C     NON-EXECUTABLE STATEMENTS

 100  format(/,1X,'Subroutine CHECKH uses dense matrices up to ',
     +            'dimension ',I6,' times ',I6,'. The Hessian ',
     +            'checking will be skipped.')

 200  format(/,1X,'Hessian matrix of the objective function column by ',
     +            'column.')
 210  format(/,1X,'Column:  ',I6)
 220  format(/,1X,'Index',13X,'evalh',3X,'Incr. Quoc. (two different ',
     +            'steps)',4X,'Absolute error')
 230  format(  1X,I5,4(3X,1P,D15.8))
 240  format(  1X,'All the elements of this column are null.')
 250  format(  1X,'Maximum absolute error = ',1P,D15.8)
 260  format(  1X,'Column ',I6,' Maximum absolute error = ',1P,D15.8)
 270  format(/,1X,'Overall maximum absolute error = ',1P,D15.8)

      end

C     *****************************************************************
C     *****************************************************************

      subroutine checkjac(n,x,ind,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer ind,inform,n

C     ARRAY ARGUMENTS
      double precision x(n)

C     This subrotutine checks the user supplied subroutine evaljac for
C     computing the gradients of the constraints using central finite
C     differences with two different discretization steps.

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      double precision bignum,macheps,macheps12,macheps13,macheps23

C     COMMON BLOCKS
      common /machcon/ bignum,macheps,macheps12,macheps13,macheps23
      save   /machcon/

C     LOCAL SCALARS
      logical nullcol
      integer i,jcnnz
      double precision cminus,cplus,jacdiff1,jacdiff2,maxerr,step1,
     +        step2,tmp

C     LOCAL ARRAYS
      integer jcvar(nmax)
      double precision g(nmax),jcval(nmax)

C     COMPUTE THE GRADIENT OF THE CONSTRAINT AND SAVE IT INTO A DENSE
C     VECTOR

      call vevaljac(n,x,ind,jcvar,jcval,jcnnz,inform)
      if ( inform .lt. 0 ) return

      do i = 1,n
          g(i) = 0.0d0
      end do

      do i = 1,jcnnz
          g(jcvar(i)) = g(jcvar(i)) + jcval(i)
      end do

C     COMPARE WITH CENTRAL FINITE DIFFERENCES

      write(* ,100) ind
      write(10,100) ind

      maxerr = 0.0d0

      nullcol = .true.

      do i = 1,n
          tmp  = x(i)

          step1 = macheps13 * max( abs( tmp ), 1.0d0 )

          x(i) = tmp + step1
          call vevalc(n,x,ind,cplus,inform)
          if ( inform .lt. 0 ) return

          x(i) = tmp - step1
          call vevalc(n,x,ind,cminus,inform)
          if ( inform .lt. 0 ) return

          jacdiff1 = ( cplus - cminus ) / ( 2.0d0 * step1 )

          step2 = macheps13 * max( abs( tmp ), 1.0d-03 )

          x(i) = tmp + step2
          call vevalc(n,x,ind,cplus,inform)
          if ( inform .lt. 0 ) return

          x(i) = tmp - step2
          call vevalc(n,x,ind,cminus,inform)
          if ( inform .lt. 0 ) return

          x(i) = tmp

          jacdiff2 = ( cplus - cminus ) / ( 2.0d0 * step2 )

          tmp = min( abs( g(i) - jacdiff1 ), abs( g(i) - jacdiff2 ) )

          if ( g(i)     .ne. 0.0d0 .or.
     +         jacdiff1 .ne. 0.0d0 .or.
     +         jacdiff2 .ne. 0.0d0 ) then
              if ( nullcol ) then
                  nullcol = .false.
                  write(* ,110)
                  write(10,110)
              end if
              write(* ,120) i,g(i),jacdiff1,jacdiff2,tmp
              write(10,120) i,g(i),jacdiff1,jacdiff2,tmp
          end if

          maxerr = max( maxerr, tmp )
      end do

      if ( nullcol ) then
          write(* ,130)
          write(10,130)
      else
          write(* ,140) maxerr
          write(10,140) maxerr
      end if

C     NON-EXECUTABLE STATEMENTS

 100  format(/,1X,'Gradient vector of constraints ',I5,'.')
 110  format(/,1X,'Index',11X,'evaljac',2X,'Central diff (two ',
     +            'different steps)',4X,'Absolute error')
 120  format(  1X,I5,4(3X,1P,D15.8))
 130  format(  1X,'All the elements of this gradient are null.')
 140  format(  1X,'Maximum absolute error = ',1P,D15.8)

      end

C     *****************************************************************
C     *****************************************************************
      subroutine checkhc(n,x,ind,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer ind,inform,n

C     ARRAY ARGUMENTS
      double precision x(n)

C     This subrotutine checks the user supplied subroutine evalhc for
C     computing the Hessians of the constraints using finite
C     differences.

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      double precision bignum,macheps,macheps12,macheps13,macheps23

C     COMMON BLOCKS
      common /machcon/ bignum,macheps,macheps12,macheps13,macheps23
      save   /machcon/

C     LOCAL SCALARS
      logical nullcol
      integer i,j,hnnz,jcnnz
      double precision elem,hdiff1,hdiff2,maxerr,step1,step2,tmp

C     LOCAL ARRAYS
      integer hlin(nsmax**2),hcol(nsmax**2),jcvar(nsmax)
      double precision g(nsmax),gplus1(nsmax),gplus2(nsmax),
     +        H(nsmax,nsmax),hval(nsmax**2),jcval(nsmax),maxcoe(nsmax)

C     Check viability of the test

      if ( n .gt. nsmax ) then
          write(*, 100) nsmax,nsmax
          write(10,100) nsmax,nsmax

          return
      end if

C     Compute the gradient of constraint ind at x and save it in a
C     dense vector

      call vevaljac(n,x,ind,jcvar,jcval,jcnnz,inform)
      if ( inform .lt. 0 ) return

      do i = 1,n
          g(i) = 0.0d0
      end do

      do i = 1,jcnnz
          g(jcvar(i)) = g(jcvar(i)) + jcval(i)
      end do

C     Compute the Hessian of constraint ind at x and save it in a
C     dense matrix

      call vevalhc(n,x,ind,hlin,hcol,hval,hnnz,inform)
      if ( inform .lt. 0 ) return

      do j = 1,n
          do i = 1,n
              H(i,j) = 0.0d0
          end do
      end do

      do i = 1,hnnz
          H(hlin(i),hcol(i)) = H(hlin(i),hcol(i)) + hval(i)
      end do

      write(* ,200) ind
      write(10,200) ind

      maxerr = 0.0d0

      do j = 1,n

          tmp  = x(j)

C         Compute the gradient of constraint ind at xplus1 and
C         save in a dense vector

          step1 = macheps12 * max( abs( tmp ), 1.0d0 )

          x(j) = tmp + step1
          call vevaljac(n,x,ind,jcvar,jcval,jcnnz,inform)
          if ( inform .lt. 0 ) return

          do i = 1,n
              gplus1(i) = 0.0d0
          end do

          do i = 1,jcnnz
              gplus1(jcvar(i)) = jcval(i)
          end do

C         Compute the gradient of constraint ind at xplus2 and
C         save in a dense vector

          step2 = macheps12 * max( abs( tmp ), 1.0d-03 )

          x(j) = tmp + step2
          call vevaljac(n,x,ind,jcvar,jcval,jcnnz,inform)
          if ( inform .lt. 0 ) return

          do i = 1,n
              gplus2(i) = 0.0d0
          end do

          do i = 1,jcnnz
              gplus2(jcvar(i)) = jcval(i)
          end do

          x(j) = tmp

          write(* ,210) j
          write(10,210) j

          maxcoe(j) = 0.0d0

          nullcol = .true.

          do i = 1,n
              if ( i .ge. j ) then
                  elem = H(i,j)
              else
                  elem = H(j,i)
              end if
              hdiff1 = ( gplus1(i) - g(i) ) / step1
              hdiff2 = ( gplus2(i) - g(i) ) / step2
              tmp = min( abs( elem - hdiff1 ), abs( elem - hdiff2 ) )

              if ( elem   .ne. 0.0d0 .or.
     +             hdiff1 .ne. 0.0d0 .or.
     +             hdiff2 .ne. 0.0d0 ) then
                  if ( nullcol ) then
                      nullcol = .false.
                      write(* ,220)
                      write(10,220)
                  end if
                  write(* ,230) i,elem,hdiff1,hdiff2,tmp
                  write(10,230) i,elem,hdiff1,hdiff2,tmp
              end if

              maxcoe(j) = max( maxcoe(j), tmp )
          end do

          maxerr = max( maxerr, maxcoe(j) )

          if ( nullcol ) then
              write(* ,240)
              write(10,240)
          else
              write(* ,250) maxcoe(j)
              write(10,250) maxcoe(j)
          end if

      end do

      write(* ,*)
      write(10,*)

      do j = 1,n
          write(* ,260) j,maxcoe(j)
          write(10,260) j,maxcoe(j)
      end do

      write(* ,270) maxerr
      write(10,270) maxerr

C     NON-EXECUTABLE STATEMENTS

 100  format(/,1X,'Subroutine CHECKHC uses dense matrices up to ',
     +            'dimension ',I6,' times ',I6,'. The Hessian ',
     +            'checking will be skipped.')

 200  format(/,1X,'Hessian matrix of constraint ',I5,' column by ',
     +            'column.')
 210  format(/,1X,'Column:  ',I6)
 220  format(/,1X,'Index',12X,'evalhc',3X,'Incr. Quoc. (two different ',
     +            'steps)',4X,'Absolute error')
 230  format(  1X,I5,4(3X,1P,D15.8))
 240  format(  1X,'All the elements of this column are null.')
 250  format(  1X,'Maximum absolute error = ',1P,D15.8)
 260  format(  1X,'Column ',I6,' Maximum absolute error = ',1P,D15.8)
 270  format(/,1X,'Overall maximum absolute error = ',1P,D15.8)

      end

C     *****************************************************************
C     *****************************************************************

      subroutine checkgjac(n,m,x,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,m,n

C     ARRAY ARGUMENTS
      double precision x(n)

C     This subrotutine checks the user supplied subroutine evalgjac for
C     computing the gradient of the objective function plus the Jacobian
C     of the constraints. It uses central finite differences with two 
C     different discretization steps.

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      double precision bignum,macheps,macheps12,macheps13,macheps23

C     COMMON BLOCKS
      common /machcon/ bignum,macheps,macheps12,macheps13,macheps23
      save   /machcon/

C     LOCAL SCALARS
      logical nullcol
      integer i,ind,jcnnz
      double precision fminus,fplus,gdiff1,gdiff2,jacdiff1,jacdiff2,
     +        maxerr,step1,step2,tmp

C     LOCAL ARRAYS
      integer jcfun(jcnnzmax),jcvar(jcnnzmax)
      double precision cminus(mmax),cplus(mmax),g(nmax),jcval(jcnnzmax)


C     COMPUTE GRADIENT OF OBJECTIVE FUNCTION AND JACOBIAN OF 
C     CONSTRAINTS AT THE CURRENT POINT

      call vevalgjac(n,x,g,m,jcfun,jcvar,jcval,jcnnz,inform)
      if ( inform .lt. 0 ) return

C     CHECK GRADIENT OF THE OBJECTIVE FUNCTION

      write(* ,100)
      write(10,100)

      maxerr = 0.0d0

      do i = 1,n
          tmp  = x(i)

          step1 = macheps13 * max( abs( tmp ), 1.0d0 )

          x(i) = tmp + step1
          call vevalfc(n,x,fplus,m,cplus,inform)
          if ( inform .lt. 0 ) return

          x(i) = tmp - step1
          call vevalfc(n,x,fminus,m,cminus,inform)
          if ( inform .lt. 0 ) return

          gdiff1 = ( fplus - fminus ) / ( 2.0d0 * step1 )

          step2 = macheps13 * max( abs( tmp ), 1.0d-03 )

          x(i) = tmp + step2
          call vevalfc(n,x,fplus,m,cplus,inform)
          if ( inform .lt. 0 ) return

          x(i) = tmp - step2
          call vevalfc(n,x,fminus,m,cminus,inform)
          if ( inform .lt. 0 ) return

          x(i) = tmp

          gdiff2 = ( fplus - fminus ) / ( 2.0d0 * step2 )

          tmp = min( abs( g(i) - gdiff1 ), abs( g(i) - gdiff2 ) )

          write(* ,110) i,g(i),gdiff1,gdiff2,tmp
          write(10,110) i,g(i),gdiff1,gdiff2,tmp

          maxerr = max( maxerr, tmp )

      end do

      write(* ,120) maxerr
      write(10,120) maxerr

C     CHECK JACOBIAN OF CONSTRAINTS

      do ind = 1,m

C         COPY GRADIENT OF IND-TH CONSTRAINT INTO A DENSE VECTOR

          do i = 1,n
              g(i) = 0.0d0
          end do

          do i = 1,jcnnz
              if ( jcfun(i) .eq. ind ) then
                  g(jcvar(i)) = g(jcvar(i)) + jcval(i)
              end if
          end do

C         COMPARE WITH CENTRAL FINITE DIFFERENCES

          write(* ,200) ind
          write(10,200) ind

          maxerr = 0.0d0

          nullcol = .true.

          do i = 1,n
              tmp  = x(i)

              step1 = macheps13 * max( abs( tmp ), 1.0d0 )

              x(i) = tmp + step1
              call vevalfc(n,x,fplus,m,cplus,inform)
              if ( inform .lt. 0 ) return

              x(i) = tmp - step1
              call vevalfc(n,x,fminus,m,cminus,inform)
              if ( inform .lt. 0 ) return

              jacdiff1 = ( cplus(ind) - cminus(ind) ) / ( 2.0d0 * step1)

              step2 = macheps13 * max( abs( tmp ), 1.0d-03 )

              x(i) = tmp + step2
              call vevalfc(n,x,fplus,m,cplus,inform)
              if ( inform .lt. 0 ) return

              x(i) = tmp - step2
              call vevalfc(n,x,fminus,m,cminus,inform)
              if ( inform .lt. 0 ) return

              x(i) = tmp

              jacdiff2 = ( cplus(ind) - cminus(ind) ) / ( 2.0d0 * step2)

              tmp = min( abs(g(i) - jacdiff1), abs(g(i) - jacdiff2) )

              if ( g(i)     .ne. 0.0d0 .or.
     +             jacdiff1 .ne. 0.0d0 .or.
     +             jacdiff2 .ne. 0.0d0 ) then
                  if ( nullcol ) then
                      nullcol = .false.
                      write(* ,210)
                      write(10,210)
                  end if
                  write(* ,220) i,g(i),jacdiff1,jacdiff2,tmp
                  write(10,220) i,g(i),jacdiff1,jacdiff2,tmp
              end if

              maxerr = max( maxerr, tmp )
          end do

          if ( nullcol ) then
              write(* ,230)
              write(10,230)
          else
              write(* ,120) maxerr
              write(10,120) maxerr
          end if

      end do

C     NON-EXECUTABLE STATEMENTS

 100  format(/,1X,'Gradient vector of the objective function.',
     +       /,1X,'Index',13X,'evalgjac',1X,'Central diff (two ',
     +            'different steps)',4X,'Absolute error')
 110  format(  1X,I5,4(3X,1P,D15.8))
 120  format(  1X,'Maximum absolute error = ',1P,D15.8)
 200  format(/,1X,'Gradient vector of constraints ',I5,'.')
 210  format(/,1X,'Index',11X,'evalgjac',1X,'Central diff (two ',
     +            'different steps)',4X,'Absolute error')
 220  format(  1X,I5,4(3X,1P,D15.8))
 230  format(  1X,'All the elements of this gradient are null.')

      end

C     ******************************************************************
C     ******************************************************************

      subroutine setp(n,x)

      implicit none

C     SCALAR ARGUMENTS
      integer n

C     ARRAY ARGUMENTS
      double precision x(n)

      end

C     ******************************************************************
C     ******************************************************************

      subroutine unsetp()

      implicit none

      end
C     ******************************************************************
C     ******************************************************************

      subroutine calcal(nind,x,m,lambda,rho,equatn,linear,al,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,m,nind
      double precision al

C     ARRAY ARGUMENTS
      logical equatn(m),linear(m)
      double precision lambda(m),rho(m),x(*)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      integer nt

C     COMMON ARRAYS
      integer ind(nmax)
      double precision xcomplement(nmax)

C     COMMON BLOCKS
      common /rspace/ xcomplement,ind,nt
      save   /rspace/

C     LOCAL SCALARS
      integer i

C     Complete x

      do i = 1,nt - nind
          x(nind+i) = xcomplement(i)
      end do

C     Expand x to the full space

      call expand(nind,x)

C     Compute augmented Lagrangian

      call sevalal(nt,x,m,lambda,rho,equatn,linear,al,inform)
      if ( inform .lt. 0 ) return

C     Shrink x to the reduced space

      call shrink(nind,x)

      return

      end

C     ******************************************************************
C     ******************************************************************

      subroutine calcnal(nind,x,m,lambda,rho,equatn,linear,nal,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,m,nind

C     ARRAY ARGUMENTS
      logical equatn(m),linear(m)
      double precision lambda(m),nal(*),rho(m),x(*)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      integer nt

C     COMMON ARRAYS
      integer ind(nmax)
      double precision xcomplement(nmax)

C     COMMON BLOCKS
      common /rspace/ xcomplement,ind,nt
      save   /rspace/

C     LOCAL SCALARS
      integer i

C     Complete x

      do i = 1,nt - nind
          x(nind+i) = xcomplement(i)
      end do

C     Expand x to the full space

      call expand(nind,x)

C     Compute the gradient of the augmented Lagrangian

      call sevalnal(nt,x,m,lambda,rho,equatn,linear,nal,inform)
      if ( inform .lt. 0 ) return

C     Shrink x and nal to the reduced space

      call shrink(nind,x)
      call shrink(nind,nal)

      return

      end

C     ******************************************************************
C     ******************************************************************

      subroutine calchal(nind,x,m,lambda,rho,equatn,linear,hlin,hcol,
     +hval,hnnz,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer hnnz,inform,m,nind

C     ARRAY ARGUMENTS
      logical equatn(m),linear(m)
      integer hcol(*),hlin(*)
      double precision lambda(m),hval(*),rho(m),x(*)

C     This subroutine computes the Hessian of the augmented Lagrangian
C     in the reduced space.

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      integer nt

C     COMMON ARRAYS
      integer ind(nmax)
      double precision xcomplement(nmax)

C     COMMON BLOCKS
      common /rspace/ xcomplement,ind,nt
      save   /rspace/

C     LOCAL SCALARS
      integer col,i,k,lin

C     LOCAL ARRAYS
      integer wi(nmax)

C     Complete x

      do i = 1,nt - nind
          x(nind+i) = xcomplement(i)
      end do

C     Expand x to the full space

      call expand(nind,x)

C     Compute the Hessian of the augmented Lagrangian

      call sevalhal(nt,x,m,lambda,rho,equatn,linear,hlin,hcol,hval,hnnz,
     +inform)
      if ( inform .lt. 0 ) return

C     Shrink x to the reduced space

      call shrink(nind,x)

C     Shrink representation of H

      do i = 1,nt
         wi(i) = 0
      end do

      do i = 1,nind
         wi(ind(i)) = i
      end do

      k = 0

      do i = 1,hnnz
          lin = wi(hlin(i))
          col = wi(hcol(i))

          if ( lin .ne. 0 .and. col .ne. 0 ) then
              k = k + 1
              hlin(k) = lin
              hcol(k) = col
              hval(k) = hval(i)
          end if
      end do

      hnnz = k

      end


C     ******************************************************************
C     ******************************************************************

      subroutine calchalp(nind,x,m,lambda,rho,equatn,linear,p,hp,gothl,
     +inform)

      implicit none

C     SCALAR ARGUMENTS
      logical gothl
      integer inform,m,nind

C     ARRAY ARGUMENTS
      logical equatn(m),linear(m)
      double precision hp(*),lambda(m),p(*),rho(m),x(*)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      integer nt

C     COMMON ARRAYS
      integer ind(nmax)
      double precision xcomplement(nmax)

C     COMMON BLOCKS
      common /rspace/ xcomplement,ind,nt
      save   /rspace/

C     LOCAL SCALARS
      integer i

C     Complete x

      do i = 1,nt - nind
          x(nind+i) = xcomplement(i)
      end do

C     Complete p with zeroes

      do i = 1,nt - nind
          p(nind+i) = 0.0d0
      end do

C     Expand x and p to the full space

      call expand(nind,x)
      call expand(nind,p)

C     Compute the Hessian-vector product

      call sevalhalp(nt,x,m,lambda,rho,equatn,linear,p,hp,gothl,inform)
      if ( inform .lt. 0 ) return

C     Shrink x, p and hp to the reduced space

      call shrink(nind,x)
      call shrink(nind,p)
      call shrink(nind,hp)

      end

C     ******************************************************************
C     ******************************************************************

      subroutine capplyhpre(nind,m,rho,equatn,gotp,r,z)

      implicit none

C     SCALAR ARGUMENTS
      logical gotp
      integer m,nind

C     ARRAY ARGUMENTS
      logical equatn(m)
      double precision r(*),rho(m),z(*)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      integer nt

C     COMMON ARRAYS
      integer ind(nmax)
      double precision xcomplement(nmax)

C     COMMON BLOCKS
      common /rspace/ xcomplement,ind,nt
      save   /rspace/

C     LOCAL SCALARS
      integer i

C     Complete r with zeroes

      do i = nind + 1,nt
          r(i) = 0.0d0
      end do

C     Expand r to the full space

      call expand(nind,r)

C     Solve P z = r

      call applyhpre(nt,m,rho,equatn,gotp,r,z)

C     Shrink r and z to the reduced space

      call shrink(nind,r)
      call shrink(nind,z)

      end

C     ******************************************************************
C     ******************************************************************

      subroutine csetp(nind,x)

      implicit none

C     SCALAR ARGUMENTS
      integer nind

C     ARRAY ARGUMENTS
      double precision x(*)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      integer nt

C     COMMON ARRAYS
      integer ind(nmax)
      double precision xcomplement(nmax)

C     COMMON BLOCKS
      common /rspace/ xcomplement,ind,nt
      save   /rspace/

C     LOCAL SCALARS
      integer i

C     Complete x

      do i = 1,nt - nind
          x(nind+i) = xcomplement(i)
      end do

C     Expand x to the full space

      call expand(nind,x)

C     Set point

      call ssetp(nt,x)

C     Shrink x

      call shrink(nind,x)

      return

      end

C     ******************************************************************
C     ******************************************************************

      subroutine shrink(nind,v)

      implicit none

C     This subroutine shrinks vector v from the full dimension space
C     (dimension n) to the reduced space (dimension nind).

C     SCALAR ARGUMENTS
      integer nind

C     ARRAY ARGUMENTS
      double precision v(*)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      integer nt

C     COMMON ARRAYS
      integer ind(nmax)
      double precision xcomplement(nmax)

C     COMMON BLOCKS
      common /rspace/ xcomplement,ind,nt
      save   /rspace/

C     LOCAL SCALARS
      integer i,indi
      double precision tmp

      do i = 1,nind
           indi = ind(i)
           if ( i .ne. indi ) then
               tmp     = v(indi)
               v(indi) = v(i)
               v(i)    = tmp
          end if
      end do

      end

C     ******************************************************************
C     ******************************************************************

      subroutine expand(nind,v)

      implicit none

C     This subroutine expands vector v from the reduced space
C     (dimension nind) to the full space (dimension n).

C     SCALAR ARGUMENTS
      integer nind

C     ARRAY ARGUMENTS
      double precision v(*)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      integer nt

C     COMMON ARRAYS
      integer ind(nmax)
      double precision xcomplement(nmax)

C     COMMON BLOCKS
      common /rspace/ xcomplement,ind,nt
      save   /rspace/

C     LOCAL SCALARS
      integer i,indi
      double precision tmp

      do i = nind,1,- 1
          indi = ind(i)
          if ( i .ne. indi ) then
              tmp     = v(indi)
              v(indi) = v(i)
              v(i)    = tmp
          end if
      end do

      end

C     *****************************************************************
C     *****************************************************************

      subroutine sevalal(n,x,m,lambda,rho,equatn,linear,al,inform)

      implicit none

C     SCALAR ARGUMENTS
      double precision al
      integer inform,m,n

C     ARRAY ARGUMENTS
      logical equatn(m),linear(m)
      double precision lambda(m),rho(m),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical constrc,gotc

C     COMMON ARRAYS
      integer jcvar(jcnnzmax),jcsta(mmax),jclen(mmax)
      double precision c(mmax),dpdc(mmax),g(nmax),gparc(nmax),
     +        jcval(jcnnzmax)

C     COMMON BLOCKS
      common /gdata/ g,gparc,c,dpdc,jcval,jcvar,jcsta,jclen,constrc,gotc
      save   /gdata/
C     COMMON SCALARS
      character * 6 hptype
      character * 2 innslvr
      logical ccoded,fccoded,fcoded,gcoded,gjaccoded,innercall,jaccoded,
     +        hcoded,hccoded,hlcoded,hlpcoded,firstde,truehl,ignoref,
     +        skipacc,sclsys,useustp,safemode

C     COMMON BLOCKS
      common /algparam/ fcoded,gcoded,hcoded,ccoded,jaccoded,hccoded,
     +                  hlcoded,hlpcoded,fccoded,gjaccoded,firstde,
     +                  truehl,ignoref,skipacc,sclsys,innercall,useustp,
     +                  innslvr,hptype,safemode
      save   /algparam/

C     LOCAL SCALARS
      integer j
      double precision f,p

      if ( innercall ) then
          call minsqf(n,x,al,inform)
          return
      end if

      if ( fccoded ) then

C         COMPUTE OBJECTIVE FUNTION AND CONSTRAINTS
          call sevalfc(n,x,f,m,c,inform)
          if ( inform .lt. 0 ) return

C         COMPUTES AL = f + sum_j P(c_j, rho_j, lambda_j)
          al = f

          do j = 1,m
C             ADD P(c_j, rho_j, lambda_j)
              call evalp(c(j),rho(j),lambda(j),equatn(j),p)
              al = al + p
          end do

      else if ( fcoded .and. ( ccoded .or. m .eq. 0 ) ) then

C         COMPUTE OBJECTIVE FUNCTION
          call sevalf(n,x,f,inform)
          if ( inform .lt. 0 ) return

C         COMPUTES AL = f + sum_j P(c_j, rho_j, lambda_j)
          al = f

          do j = 1,m
C             COMPUTE j-TH CONSTRAINT
              call sevalc(n,x,j,c(j),inform)
              if ( inform .lt. 0 ) return

C             ADD P(c_j, rho_j, lambda_j)
              call evalp(c(j),rho(j),lambda(j),equatn(j),p)
              al = al + p
          end do

      end if

      gotc = .true.

      end

C     *****************************************************************
C     *****************************************************************

      subroutine sevalnl(n,x,m,lambda,equatn,linear,nl,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,m,n

C     ARRAY ARGUMENTS
      logical equatn(m),linear(m)
      double precision lambda(m),nl(n),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      character * 6 hptype
      character * 2 innslvr
      logical ccoded,fccoded,fcoded,gcoded,gjaccoded,innercall,jaccoded,
     +        hcoded,hccoded,hlcoded,hlpcoded,firstde,truehl,ignoref,
     +        skipacc,sclsys,useustp,safemode

C     COMMON BLOCKS
      common /algparam/ fcoded,gcoded,hcoded,ccoded,jaccoded,hccoded,
     +                  hlcoded,hlpcoded,fccoded,gjaccoded,firstde,
     +                  truehl,ignoref,skipacc,sclsys,innercall,useustp,
     +                  innslvr,hptype,safemode
      save   /algparam/
C     COMMON SCALARS
      logical constrc,gotc

C     COMMON ARRAYS
      integer jcvar(jcnnzmax),jcsta(mmax),jclen(mmax)
      double precision c(mmax),dpdc(mmax),g(nmax),gparc(nmax),
     +        jcval(jcnnzmax)

C     COMMON BLOCKS
      common /gdata/ g,gparc,c,dpdc,jcval,jcvar,jcsta,jclen,constrc,gotc
      save   /gdata/

C     LOCAL SCALARS
      integer i,ind,j,jcnnz

C     LOCAL ARRAYS
      integer jcfun(jcnnzmax)

      if ( fccoded ) then

C         COMPUTE THE GRADIENT OF THE OBJECTIVE FUNCTION AND JACOBIAN
C         OF CONSTRAINTS
          call sevalgjac(n,x,g,m,jcfun,jcvar,jcval,jcnnz,inform)
          if ( inform .lt. 0 ) return

          do i = 1,n
              nl(i)    = g(i)
              gparc(i) = g(i)
          end do

C         CONVERT JACOBIAN OF CONSTRAINTS FROM COORDINATE FORMAT TO
C         COMPRESSED SPARSE ROW FORMAT
          call coo2csr(m,jcnnz,jcfun,jcvar,jcval,jclen,jcsta)

C         COMPUTE \nabla L = \nabla f + \sum_j lambda_j * \nabla c_j
          constrc = .false.

          do j = 1,m
              if ( equatn(j) .or. lambda(j) .gt. 0.0d0 ) then

C                 ADD lambda_j * \nabla c_j
                  do i = jcsta(j),jcsta(j) + jclen(j) - 1
                      nl(jcvar(i)) = nl(jcvar(i)) + lambda(j) * jcval(i)
                  end do

                  if ( .not. linear(j) ) then
                      do i = jcsta(j),jcsta(j) + jclen(j) - 1
                          gparc(jcvar(i)) =
     +                    gparc(jcvar(i)) + lambda(j) * jcval(i)
                      end do
                  end if

                  constrc = .true.

              end if
          end do

      else if ( fcoded .and. ( ccoded .or. m .eq. 0 ) ) then

C         COMPUTE THE GRADIENT OF THE OBJECTIVE FUNCTION
          call sevalg(n,x,g,inform)
          if ( inform .lt. 0 ) return

          do i = 1,n
              nl(i)    = g(i)
              gparc(i) = g(i)
          end do

C         COMPUTE \nabla L = \nabla f + \sum_j lambda_j * \nabla c_j
          constrc = .false.

          ind = 0

          do j = 1,m
              if ( equatn(j) .or. lambda(j) .gt. 0.0d0 ) then

                  jcsta(j) = ind + 1

C                 COMPUTE THE GRADIENT OF THE j-TH CONSTRAINT
                  call sevaljac(n,x,j,jcvar(ind+1),jcval(ind+1),
     +            jclen(j),inform)
                  if ( inform .lt. 0 ) return

                  ind = ind + jclen(j)

C                 ADD lambda_j * \nabla c_j
                  do i = jcsta(j),jcsta(j) + jclen(j) - 1
                      nl(jcvar(i)) = nl(jcvar(i)) + lambda(j) * jcval(i)
                  end do

                  if ( .not. linear(j) ) then
                      do i = jcsta(j),jcsta(j) + jclen(j) - 1
                          gparc(jcvar(i)) =
     +                    gparc(jcvar(i)) + lambda(j) * jcval(i)
                      end do
                  end if

                  constrc = .true.

              end if
          end do

      end if

      end

C     *****************************************************************
C     *****************************************************************

      subroutine sevalnal(n,x,m,lambda,rho,equatn,linear,nal,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,m,n

C     ARRAY ARGUMENTS
      logical equatn(m),linear(m)
      double precision lambda(m),nal(n),rho(m),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical constrc,gotc

C     COMMON ARRAYS
      integer jcvar(jcnnzmax),jcsta(mmax),jclen(mmax)
      double precision c(mmax),dpdc(mmax),g(nmax),gparc(nmax),
     +        jcval(jcnnzmax)

C     COMMON BLOCKS
      common /gdata/ g,gparc,c,dpdc,jcval,jcvar,jcsta,jclen,constrc,gotc
      save   /gdata/
C     COMMON SCALARS
      character * 6 hptype
      character * 2 innslvr
      logical ccoded,fccoded,fcoded,gcoded,gjaccoded,innercall,jaccoded,
     +        hcoded,hccoded,hlcoded,hlpcoded,firstde,truehl,ignoref,
     +        skipacc,sclsys,useustp,safemode

C     COMMON BLOCKS
      common /algparam/ fcoded,gcoded,hcoded,ccoded,jaccoded,hccoded,
     +                  hlcoded,hlpcoded,fccoded,gjaccoded,firstde,
     +                  truehl,ignoref,skipacc,sclsys,innercall,useustp,
     +                  innslvr,hptype,safemode
      save   /algparam/

C     LOCAL SCALARS
      integer j
      double precision dum

      if ( innercall ) then
          call minsqg(n,x,nal,inform)
          return
      end if

      if ( fccoded ) then
C         COMPUTE CONSTRAINTS
          if ( .not. gotc .and. m .gt. 0 ) then
              call sevalfc(n,x,dum,m,c,inform)
              if ( inform .lt. 0 ) return
          end if

          do j = 1,m
C             COMPUTE dP/dc
              call evaldpdy(c(j),rho(j),lambda(j),equatn(j),dpdc(j))
          end do

      else if ( fcoded .and. ( ccoded .or. m .eq. 0 ) ) then
          if ( .not. gotc ) then
              do j = 1,m
C                 COMPUTE THE j-TH CONSTRAINT
                  call sevalc(n,x,j,c(j),inform)
                  if ( inform .lt. 0 ) return
              end do
          end if

          do j = 1,m
C             COMPUTE dP/dc
              call evaldpdy(c(j),rho(j),lambda(j),equatn(j),dpdc(j))
          end do

      end if

      gotc = .true.

C     COMPUTE GRADIENT OF THE LAGRANGIAN WITH DPDC INSTEAD OF LAMBDA
      call sevalnl(n,x,m,dpdc,equatn,linear,nal,inform)
      if ( inform .lt. 0 ) return

      end

C     *****************************************************************
C     *****************************************************************

      subroutine evalp(y,rho,lambda,equatn,p)

      implicit none

C     SCALAR ARGUMENTS
      logical equatn
      double precision lambda,p,rho,y

      if ( equatn ) then
          p  = y * ( lambda + 0.5d0 * rho * y )
      else
          if ( lambda + rho * y .ge. 0.0d0 ) then
              p = y * ( lambda + 0.5d0 * rho * y )
          else
              p = - 0.5d0 * lambda ** 2 / rho
          end if
      end if

      end

C     *****************************************************************
C     *****************************************************************

      subroutine evaldpdy(y,rho,lambda,equatn,dpdy)

      implicit none

C     SCALAR ARGUMENTS
      logical equatn
      double precision y,rho,lambda,dpdy

      if ( equatn ) then
          dpdy = lambda + rho * y
      else
          dpdy = max( 0.0d0, lambda + rho * y )
      end if

      end

C     *****************************************************************
C     *****************************************************************

      subroutine ievalnal(n,xp,m,lambda,rho,equatn,linear,nalp,nalpparc,
     +inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,m,n

C     ARRAY ARGUMENTS
      logical equatn(m),linear(m)
      double precision lambda(m),nalp(n),nalpparc(n),rho(m),xp(n)

C     This subroutine computes the gradient of the Augmented Lagrangian
C     function at a point xp, which is near to x, taking care of the
C     non-differentiability. The Augmented Lagrangian gradient must be
C     previously computed at x.

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      character * 6 hptype
      character * 2 innslvr
      logical ccoded,fccoded,fcoded,gcoded,gjaccoded,innercall,jaccoded,
     +        hcoded,hccoded,hlcoded,hlpcoded,firstde,truehl,ignoref,
     +        skipacc,sclsys,useustp,safemode

C     COMMON BLOCKS
      common /algparam/ fcoded,gcoded,hcoded,ccoded,jaccoded,hccoded,
     +                  hlcoded,hlpcoded,fccoded,gjaccoded,firstde,
     +                  truehl,ignoref,skipacc,sclsys,innercall,useustp,
     +                  innslvr,hptype,safemode
      save   /algparam/
C     COMMON SCALARS
      logical constrc,gotc

C     COMMON ARRAYS
      integer jcvar(jcnnzmax),jcsta(mmax),jclen(mmax)
      double precision c(mmax),dpdc(mmax),g(nmax),gparc(nmax),
     +        jcval(jcnnzmax)

C     COMMON BLOCKS
      common /gdata/ g,gparc,c,dpdc,jcval,jcvar,jcsta,jclen,constrc,gotc
      save   /gdata/

C     LOCAL SCALARS
      integer i,j,jcpnnz
      double precision cpj,dpdcp,dum

C     LOCAL ARRAYS
      integer jcpfun(jcnnzmax),jcplen(mmax),jcpsta(mmax),
     +        jcpvar(jcnnzmax)
      double precision cp(mmax),gp(nmax),jcpval(jcnnzmax)

      if ( innercall ) then
          call minsqg(n,xp,nalp,inform)
          return
      end if

c     call ssetp(n,xp)

      if ( fccoded ) then

C         COMPUTE CONSTRAINTS AT xp
          if ( m .gt. 0 ) then
              call sevalfc(n,xp,dum,m,cp,inform)
              if ( inform .lt. 0 ) return
          end if

C         COMPUTE THE GRADIENT OF THE OBJECTIVE FUNCTION AND JACOBIAN
C         OF CONSTRAINTS AT xp
          call sevalgjac(n,xp,gp,m,jcpfun,jcpvar,jcpval,jcpnnz,inform)
          if ( inform .lt. 0 ) return

          do i = 1,n
              nalp(i)     = gp(i)
              nalpparc(i) = gp(i)
          end do

C         CONVERT JACOBIAN OF CONSTRAINTS FROM COODINATE FORMAT TO
C         COMPRESSED SPARSE ROW FORMAT
          call coo2csr(m,jcpnnz,jcpfun,jcpvar,jcpval,jcplen,jcpsta)

C         COMPUTE \nabla L = \nabla f + \sum_j dPdc * dcdx
          do j = 1,m
              if ( equatn(j) .or. dpdc(j) .gt. 0.0d0 ) then

C                 COMPUTE dP/dc
                  dpdcp = lambda(j) + rho(j) * cp(j)

C                 ADD dPdc * dcdx
                  if ( dpdcp .ne. 0.0d0 ) then
                      do i = jcpsta(j),jcpsta(j) + jcplen(j) - 1
                          nalp(jcpvar(i)) =
     +                    nalp(jcpvar(i)) + dpdcp * jcpval(i)
                      end do

                      if ( .not. linear(j) ) then
                          do i = jcpsta(j),jcpsta(j) + jcplen(j) - 1
                              nalpparc(jcpvar(i)) =
     +                        nalpparc(jcpvar(i)) + dpdcp * jcpval(i)
                          end do
                      end if
                  end if

              end if
          end do

      else if ( fcoded .and. ( ccoded .or. m .eq. 0 ) ) then

C         COMPUTE THE GRADIENT OF THE OBJECTIVE FUNCTION AT xp
          call sevalg(n,xp,gp,inform)
          if ( inform .lt. 0 ) return

          do i = 1,n
              nalp(i)     = gp(i)
              nalpparc(i) = gp(i)
          end do

C         COMPUTE \nabla L = \nabla f + \sum_j dPdc * dcdx
          do j = 1,m
              if ( equatn(j) .or. dpdc(j) .gt. 0.0d0 ) then

C                 COMPUTE THE i-TH CONSTRAINT
                  call sevalc(n,xp,j,cpj,inform)
                  if ( inform .lt. 0 ) return

C                 COMPUTE dP/dc
                  dpdcp = lambda(j) + rho(j) * cpj

                  if ( dpdcp .ne. 0.0d0 ) then
C                     COMPUTE THE GRADIENT OF THE j-TH CONSTRAINT
                      call sevaljac(n,xp,j,jcpvar,jcpval,jcpnnz,inform)
                      if ( inform .lt. 0 ) return

C                     ADD dPdc * dcdx
                      do i = 1,jcpnnz
                          nalp(jcpvar(i)) =
     +                    nalp(jcpvar(i)) + dpdcp * jcpval(i)
                      end do

                      if ( .not. linear(j) ) then
                          do i = 1,jcpnnz
                              nalpparc(jcpvar(i)) =
     +                        nalpparc(jcpvar(i)) + dpdcp * jcpval(i)
                          end do
                      end if
                  end if

              end if
          end do
      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine sevalhal(n,x,m,lambda,rho,equatn,linear,hallin,halcol,
     +halval,halnnz,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer halnnz,inform,m,n

C     ARRAY ARGUMENTS
      logical equatn(m),linear(m)
      integer hallin(*),halcol(*)
      double precision lambda(m),halval(*),rho(m),x(n)

C     This subroutine computes the Hessian of the augmented Lagrangian.

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical constrc,gotc

C     COMMON ARRAYS
      integer jcvar(jcnnzmax),jcsta(mmax),jclen(mmax)
      double precision c(mmax),dpdc(mmax),g(nmax),gparc(nmax),
     +        jcval(jcnnzmax)

C     COMMON BLOCKS
      common /gdata/ g,gparc,c,dpdc,jcval,jcvar,jcsta,jclen,constrc,gotc
      save   /gdata/

C     LOCAL SCALARS
      integer i,lin,j,k,l,var

C     LOCAL ARRAYS
      integer stlin(nmax)
      double precision r(nmax)

      call sevalhl(n,x,m,dpdc,hallin,halcol,halval,halnnz,inform)
      if ( inform .lt. 0 ) return

      if ( m .eq. 0 ) return

C     PUT MATRIX INTO A ROW-LINKED LIST

      do i = 1,n
         r(i) = 0.0d0
      end do

      do i = 1,n
          stlin(i) = 0
      end do

      do i = 1,halnnz
          lin = hallin(i)
          k   = stlin(lin)
          stlin(lin) = i
          hallin(i)  = k
      end do

C     ADD \sum_j \rho_j * \nabla c_j \nabla c_j^t

      do j = 1,m

          if ( equatn(j) .or. dpdc(j) .gt. 0.0d0 ) then

C             ADD \rho_j * \nabla c_j \nabla c_j^t

              do k = jcsta(j),jcsta(j) + jclen(j) - 1

                  var = jcvar(k)

C                 PUT ROW jcvar(k) INTO A DENSE VECTOR

                  lin = stlin(var)
 10               if ( lin .ne. 0 ) then
                      r(halcol(lin)) = r(halcol(lin)) + halval(lin)
                      lin = hallin(lin)
                      go to 10
                  end if

C                 ADD VALUE

                  do l = jcsta(j),jcsta(j) + jclen(j) - 1
                      if ( jcvar(l) .le. var ) then
                          r(jcvar(l)) =
     +                    r(jcvar(l)) + rho(j) * jcval(l) * jcval(k)
                      end if
                  end do

C                 UPDATE VALUES IN HALVAL

                  lin = stlin(var)
 20               if ( lin .ne. 0 ) then
                      halval(lin) = r(halcol(lin))
                      r(halcol(lin)) = 0.0d0
                      lin = hallin(lin)
                      go to 20
                  end if

C                 INSERT NEW ELEMENTS IN HAL REPRESENTATION

                  do i = jcsta(j),jcsta(j) + jclen(j) - 1
                      l = jcvar(i)
                      if ( r(l) .ne. 0.0d0 ) then
                          halnnz = halnnz + 1
                          halval(halnnz) = r(l)
                          halcol(halnnz) = l
                          hallin(halnnz) = stlin(var)
                          stlin(var) = halnnz
                          r(l) = 0.0d0
                      end if
                  end do

              end do

          end if

      end do

C     PUT MATRIX BACK INTO COORDINATE SQUEME

      do i = 1,n

          lin = stlin(i)
 30       if ( lin .ne. 0 ) then
              k = hallin(lin)
              hallin(lin) = i
              lin = k
              go to 30
          end if

      end do

      end

C     *****************************************************************
C     *****************************************************************

      subroutine sevalhalp(n,x,m,lambda,rho,equatn,linear,p,hp,gothl,
     +inform)

      implicit none

C     SCALAR ARGUMENTS
      logical gothl
      integer inform,m,n

C     ARRAY ARGUMENTS
      logical equatn(m),linear(m)
      double precision hp(n),lambda(m),p(n),rho(m),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical constrc,gotc

C     COMMON ARRAYS
      integer jcvar(jcnnzmax),jcsta(mmax),jclen(mmax)
      double precision c(mmax),dpdc(mmax),g(nmax),gparc(nmax),
     +        jcval(jcnnzmax)

C     COMMON BLOCKS
      common /gdata/ g,gparc,c,dpdc,jcval,jcvar,jcsta,jclen,constrc,gotc
      save   /gdata/
C     COMMON SCALARS
      character * 6 hptype
      character * 2 innslvr
      logical ccoded,fccoded,fcoded,gcoded,gjaccoded,innercall,jaccoded,
     +        hcoded,hccoded,hlcoded,hlpcoded,firstde,truehl,ignoref,
     +        skipacc,sclsys,useustp,safemode

C     COMMON BLOCKS
      common /algparam/ fcoded,gcoded,hcoded,ccoded,jaccoded,hccoded,
     +                  hlcoded,hlpcoded,fccoded,gjaccoded,firstde,
     +                  truehl,ignoref,skipacc,sclsys,innercall,useustp,
     +                  innslvr,hptype,safemode
      save   /algparam/

C     LOCAL SCALARS
      integer i,j
      double precision atp

      if ( innercall ) then
          call minsqhp(n,x,p,hp,gothl,inform)
          return
      end if

C     --------------------------------------------------------------
C     Hessian approximation
C     --------------------------------------------------------------

      if ( hptype .eq. 'HAPPRO' .and. constrc ) then

          call applyhapp(n,m,rho,equatn,gothl,p,hp)

C     --------------------------------------------------------------
C     Incremental quotients
C     --------------------------------------------------------------

      else if ( hptype .eq. 'INCQUO' .or. hptype .eq. 'HAPPRO' ) then

          call ievalhalp(n,x,m,lambda,rho,equatn,linear,p,hp,inform)
          if ( inform .lt. 0 ) return

C     --------------------------------------------------------------
C     True Hessian
C     --------------------------------------------------------------

      else if ( hptype .eq. 'TRUEHP' ) then

C         Compute Hessian of Lagrangian times p using dpdc
C         instead of lambda

          call sevalhlp(n,x,m,dpdc,p,hp,gothl,inform)
          if ( inform .lt. 0 ) return

C         Add rho A^T A

          do j = 1,m
              if ( equatn(j) .or. dpdc(j) .gt. 0.0d0 ) then

                  atp = 0.0d0
                  do i = jcsta(j),jcsta(j) + jclen(j) - 1
                      atp = atp + jcval(i) * p(jcvar(i))
                  end do

                  atp = atp * rho(j)

                  do i = jcsta(j),jcsta(j) + jclen(j) - 1
                      hp(jcvar(i)) = hp(jcvar(i)) + atp * jcval(i)
                  end do

              end if
          end do

      end if

      end

C     *****************************************************************
C     *****************************************************************

      subroutine ievalhalp(n,x,m,lambda,rho,equatn,linear,p,hp,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,m,n

C     ARRAY ARGUMENTS
      logical equatn(m),linear(m)
      double precision hp(n),lambda(m),p(n),rho(m),x(n)

C     Computes an approximation of the product of the Hessian of the
C     Augmented Lagrangian times a vector using incremental quotients.

C     COMMON SCALARS
      double precision bignum,macheps,macheps12,macheps13,macheps23

C     COMMON BLOCKS
      common /machcon/ bignum,macheps,macheps12,macheps13,macheps23
      save   /machcon/
C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical constrc,gotc

C     COMMON ARRAYS
      integer jcvar(jcnnzmax),jcsta(mmax),jclen(mmax)
      double precision c(mmax),dpdc(mmax),g(nmax),gparc(nmax),
     +        jcval(jcnnzmax)

C     COMMON BLOCKS
      common /gdata/ g,gparc,c,dpdc,jcval,jcvar,jcsta,jclen,constrc,gotc
      save   /gdata/

C     LOCAL SCALARS
      integer i,j
      double precision atp,psupn,step,xsupn

C     LOCAL  ARRAYS
      double precision gpparc(nmax),dum(nmax),xp(nmax)

C     ------------------------------------------------------------------
C     Set auxiliary point
C     ------------------------------------------------------------------

      xsupn = 0.0d0
      psupn = 0.0d0
      do i = 1,n
          xsupn = max( xsupn, abs( x(i) ) )
          psupn = max( psupn, abs( p(i) ) )
      end do

      step = macheps12 * max( xsupn / psupn, 1.0d0 )

      do i = 1,n
          xp(i) = x(i) + step * p(i)
      end do

C     ------------------------------------------------------------------
C     Compute gradient of the augmented Lagrangian at xp considering the
C     same constraints considered at x and ignoring linear constraints
C     ------------------------------------------------------------------

      call ssetp(n,xp)

      call ievalnal(n,xp,m,lambda,rho,equatn,linear,dum,gpparc,inform)
      if ( inform .lt. 0 ) return

C     ------------------------------------------------------------------
C     Compute gradients difference
C     ------------------------------------------------------------------

      do i = 1,n
          hp(i) = ( gpparc(i) - gparc(i) ) / step
      end do

C     ------------------------------------------------------------------
C     Add contribution of linear constraints
C     ------------------------------------------------------------------

      do j = 1,m
          if ( equatn(j) .or. dpdc(j) .gt. 0.0d0 ) then
              if ( linear(j) ) then

C                 Compute inner product <a,p>
                  atp = 0.0d0
                  do i = jcsta(j),jcsta(j) + jclen(j) - 1
                      atp = atp + jcval(i) * p(jcvar(i))
                  end do

                  atp = atp * rho(j)

C                 Add rho * atp * a
                  do i = jcsta(j),jcsta(j) + jclen(j) - 1
                      hp(jcvar(i)) = hp(jcvar(i)) + atp * jcval(i)
                  end do

              end if
          end if
      end do

      end

C     ******************************************************************
C     ******************************************************************

      subroutine coo2csr(m,nnz,alin,acol,aval,alen,asta)

      implicit none

C     SCALAR ARGUMENTS
      integer m,nnz

C     ARRAY ARGUMENTS
      integer acol(nnz),alen(m),alin(nnz),asta(m)
      double precision aval(nnz)

C     This subroutines converts a matrix from coordinate format to
C     compressed sparse row format.

C     LOCAL SCALARS
      integer i,j,col,coltmp,lin,lintmp
      double precision val,valtmp

      do i = 1,m
          alen(i) = 0
      end do

      do i = 1,nnz
          lin = alin(i)
          alen(lin) = alen(lin) + 1
      end do

      asta(1) = 1
      do i = 2,m
          asta(i) = asta(i-1) + alen(i-1)
      end do

      do i = 1,nnz

          val = aval(i)
          col = acol(i)
          lin = alin(i)

          alin(i) = - 1

 10       if ( lin .ge. 0 ) then

              j = asta(lin)
              asta(lin) = j + 1

              valtmp = aval(j)
              coltmp = acol(j)
              lintmp = alin(j)

              aval(j) = val
              acol(j) = col
              alin(j) = - 1

              val = valtmp
              col = coltmp
              lin = lintmp

              go to 10

          end if

      end do

      do i = 1,m
          asta(i) = asta(i) - alen(i)
      end do

      end

C     ******************************************************************
C     ******************************************************************

      logical function sstop(n,x,m,lambda,rho,equatn,linear,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,m,n

C     ARRAY ARGUMENTS
      logical equatn(m),linear(m)
      double precision lambda(m),rho(m),x(n)

C     LOCAL SCALARS
      integer flag

C     COMMON SCALARS
      character * 6 hptype
      character * 2 innslvr
      logical ccoded,fccoded,fcoded,gcoded,gjaccoded,innercall,jaccoded,
     +        hcoded,hccoded,hlcoded,hlpcoded,firstde,truehl,ignoref,
     +        skipacc,sclsys,useustp,safemode

C     COMMON BLOCKS
      common /algparam/ fcoded,gcoded,hcoded,ccoded,jaccoded,hccoded,
     +                  hlcoded,hlpcoded,fccoded,gjaccoded,firstde,
     +                  truehl,ignoref,skipacc,sclsys,innercall,useustp,
     +                  innslvr,hptype,safemode
      save   /algparam/

C     EXTERNAL FUNCTIONS
      logical minsqstop

      sstop = .false.

      if ( innercall ) then
          sstop = minsqstop(n,x,inform)
          return
      end if

      end
C     *****************************************************************
C     *****************************************************************

      subroutine comphapp(n,m,rho,equatn)

      implicit none

C     SCALAR ARGUMENTS
      integer m,n

C     ARRAY ARGUMENTS
      logical equatn(m)
      double precision rho(m)

C     This subroutine computes an approximation H of the Hessian of the
C     Augmented Lagrangian following a very simple idea: "discard the
C     second order terms and then correct the remaining matrix in order
C     to satisfy a secant equation".
C
C     Hence, H takes the form
C
C     H = B + S + rho A^t A,
C
C     where S is the spectral correction of (rho A^t A) and B is
C     the BFGS correction of (S + rho A^t A). More specifically,
C
C     S = hlspg I,
C
C     where
C
C     hlspg = max(lspgmi, min(lspgma, s^t (y - rho A^t A s) / s^t s)),
C
C     D = S + rho A^t A,
C
C     and
C
C     B = [ y y ^t / ( y^t s ) ] - [ D s ( D s )^t / ( s^t D s ) ].
C
C     Note that this subroutine does not compute matrix H explicitly,
C     but computes some quantities that will be used later to compute
C     the product of H by a vector p.
C
C     The quantities computed by this subroutine are:
C
C     (a) hlspg = s^t (y - rho A^t A s) / (s^t s)
C
C     (b) hds = D s = ( hlspg I + rho A^t A ) s, and
C
C     (c) hstds = <s,hds>.

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     PARAMETERS

C     General constants

      double precision fmin

      parameter ( fmin       = - 1.0d+20 )

C     Line search constants

      integer maxextrap,mininterp
      double precision beta,etaint,etaext,gamma,sigma1,sigma2

      parameter ( maxextrap  =       100 )
      parameter ( mininterp  =         4 )

      parameter ( gamma      =   1.0d-04 )
      parameter ( beta       =     0.5d0 )
      parameter ( sigma1     =     0.1d0 )
      parameter ( sigma2     =     0.9d0 )
      parameter ( etaint     =     2.0d0 )
      parameter ( etaext     =     2.0d0 )

C     Safeguarding spectral step constants

      double precision lspgma,lspgmi

      parameter ( lspgma     =   1.0d+10 )
      parameter ( lspgmi     =   1.0d-10 )

C     Conjugate gradients constants

      integer maxcgitnp
      double precision epsnqmp,theta

      parameter ( theta      =   1.0d-06 )
      parameter ( epsnqmp    =   1.0d-08 )
      parameter ( maxcgitnp  =         5 )

C     BETRA constants

      logical extrp4,extrp5
      integer msmaxit
      double precision mseps,msrho,mssig,phieps,trdelini,trdelmin,
     +        tralpha

      parameter ( extrp4     =   .true. )
      parameter ( extrp5     =   .true. )

      parameter ( msmaxit    =       20 )

      parameter ( mseps      =  1.0d-08 )
      parameter ( mssig      =  1.0d-01 )
      parameter ( msrho      =  9.0d-01 )
      parameter ( phieps     =  1.0d-08 )
      parameter ( trdelini   =  1.0d+02 )
      parameter ( trdelmin   =  1.0d-08 )
      parameter ( tralpha    =  1.0d-01 )

C     GENCAN constants

      integer maxinnitnp
      double precision cggpnf,cgepsi,cgepsf,delmin,eta

      parameter ( maxinnitnp =         3 )
      parameter ( delmin     =   1.0d+04 )
      parameter ( eta        =   0.1d0   )
      parameter ( cggpnf     =   1.0d-04 )
      parameter ( cgepsi     =   1.0d-01 )
      parameter ( cgepsf     =   1.0d-08 )

C     ALGENCAN constants

      logical rhorestart
      integer maxoutitnp,maxoutit
      double precision lammax,lammin,rhofrac,rhoinimax,rhoinimin,rhomax,
     +        rhomult

      parameter ( maxoutitnp =        10 )
      parameter ( maxoutit   =       100 )

      parameter ( lammin     = - 1.0d+20 )
      parameter ( lammax     =   1.0d+20 )

      parameter ( rhofrac    =   0.5d0   )
      parameter ( rhomult    =   1.0d+01 )
      parameter ( rhomax     =   1.0d+20 )

      parameter ( rhorestart =    .true. )
      parameter ( rhoinimin  =   1.0d-08 )
      parameter ( rhoinimax  =   1.0d+08 )
C     COMMON SCALARS
      logical constrc,gotc

C     COMMON ARRAYS
      integer jcvar(jcnnzmax),jcsta(mmax),jclen(mmax)
      double precision c(mmax),dpdc(mmax),g(nmax),gparc(nmax),
     +        jcval(jcnnzmax)

C     COMMON BLOCKS
      common /gdata/ g,gparc,c,dpdc,jcval,jcvar,jcsta,jclen,constrc,gotc
      save   /gdata/
C     COMMON SCALARS
      double precision seucn,sts,sty,yeucn

C     COMMON ARRAYS
      double precision s(nmax),y(nmax)

C     COMMON BLOCKS
      common /sydata/ s,y,seucn,yeucn,sts,sty
      save   /sydata/
C     COMMON SCALARS
      double precision hlspg,hstds

C     COMMON ARRAYS
      double precision hds(nmax)

C     COMMON BLOCKS
      common /happdata/ hlspg,hds,hstds
      save   /happdata/

C     LOCAL SCALARS
      integer i,j
      double precision ats

C     ------------------------------------------------------------------
C     Compute hds = rho A^t A s
C     ------------------------------------------------------------------

      do i = 1,n
          hds(i) = 0.0d0
      end do

      do j = 1,m

          if ( equatn(j) .or. dpdc(j) .gt. 0.0d0 ) then

C             COMPUTE THE INNER PRODUCT <a,s>
              ats = 0.0d0
              do i = jcsta(j),jcsta(j) + jclen(j) - 1
                  ats = ats + jcval(i) * s(jcvar(i))
              end do

              ats = ats * rho(j)

C             ADD rho * ats * a
              do i = jcsta(j),jcsta(j) + jclen(j) - 1
                  hds(jcvar(i)) = hds(jcvar(i)) + ats * jcval(i)
              end do

          end if

      end do

      hstds = 0.0d0
      do i = 1,n
          hstds = hstds + s(i) * hds(i)
      end do

C     ------------------------------------------------------------------
C     Compute hlspg = s^t (y - rho A^t A s) / (s^t s)
C     ------------------------------------------------------------------

      if ( sty - hstds .le. 0.0d0 ) then
          hlspg = lspgmi
      else
          hlspg = max( lspgmi, min( (sty - hstds) / sts, lspgma ) )
      end if

      do i = 1,n
          hds(i) = hds(i) + hlspg * s(i)
      end do

      hstds = hstds + hlspg * sts

      end

C     *****************************************************************
C     *****************************************************************

      subroutine applyhapp(n,m,rho,equatn,goth,p,hp)

      implicit none

C     SCALAR ARGUMENTS
      logical goth
      integer m,n

C     ARRAY ARGUMENTS
      logical equatn(m)
      double precision hp(n),p(n),rho(m)

C     This subroutine computes the product of the matrix computed by
C     subroutine comphapp times vector p.

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      double precision bignum,macheps,macheps12,macheps13,macheps23

C     COMMON BLOCKS
      common /machcon/ bignum,macheps,macheps12,macheps13,macheps23
      save   /machcon/
C     COMMON SCALARS
      logical constrc,gotc

C     COMMON ARRAYS
      integer jcvar(jcnnzmax),jcsta(mmax),jclen(mmax)
      double precision c(mmax),dpdc(mmax),g(nmax),gparc(nmax),
     +        jcval(jcnnzmax)

C     COMMON BLOCKS
      common /gdata/ g,gparc,c,dpdc,jcval,jcvar,jcsta,jclen,constrc,gotc
      save   /gdata/
C     COMMON SCALARS
      double precision seucn,sts,sty,yeucn

C     COMMON ARRAYS
      double precision s(nmax),y(nmax)

C     COMMON BLOCKS
      common /sydata/ s,y,seucn,yeucn,sts,sty
      save   /sydata/
C     COMMON SCALARS
      logical sameface
      integer ittype

C     COMMON BLOCKS
      common /itedat/ sameface,ittype
      save   /itedat/
C     COMMON SCALARS
      double precision hlspg,hstds

C     COMMON ARRAYS
      double precision hds(nmax)

C     COMMON BLOCKS
      common /happdata/ hlspg,hds,hstds
      save   /happdata/

C     LOCAL SCALARS
      integer i,j
      double precision atp,c1,c2,ptds,pty

C     ------------------------------------------------------------------
C     Compute Hessian approximation
C     ------------------------------------------------------------------

      if ( .not. goth ) then
          goth = .true.
          call comphapp(n,m,rho,equatn)
      end if

C     ------------------------------------------------------------------
C     Compute ( hlspg I ) p
C     ------------------------------------------------------------------

      do i = 1,n
          hp(i) = hlspg * p(i)
      end do

C     ------------------------------------------------------------------
C     Add ( rho A^T A ) p
C     ------------------------------------------------------------------

      do j = 1,m

          if ( equatn(j) .or. dpdc(j) .gt. 0.0d0 ) then

C             COMPUTE THE INNER PRODUCT <a,p>
              atp = 0.0d0
              do i = jcsta(j),jcsta(j) + jclen(j) - 1
                  atp = atp + jcval(i) * p(jcvar(i))
              end do

              atp = atp * rho(j)

C             ADD rho * atp * a
              do i = jcsta(j),jcsta(j) + jclen(j) - 1
                  hp(jcvar(i)) = hp(jcvar(i)) + atp * jcval(i)
              end do

          end if

      end do

C     ------------------------------------------------------------------
C     Add B p,
C     where B = [ y y ^t / ( y^t s ) ] - [ D s ( D s )^t / ( s^t D s ) ]
C     ------------------------------------------------------------------

      if ( sameface .and. sty .gt. macheps12 * seucn * yeucn ) then

          pty = 0.0d0
          ptds = 0.0d0
          do i = 1,n
              pty = pty + p(i) * y(i)
              ptds = ptds + p(i) * hds(i)
          end do

          c1 = pty / sty
          c2 = ptds / hstds
          do i = 1,n
              hp(i) = hp(i) + c1 * y(i) - c2 * hds(i)
          end do

      end if

      end

C     *****************************************************************
C     *****************************************************************

      subroutine comphpre(n,m,rho,equatn)

      implicit none

C     SCALAR ARGUMENTS
      integer m,n

C     ARRAY ARGUMENTS
      logical equatn(m)
      double precision rho(m)

C     Consider the preconditioner
C
C         P = Q + E + diag(rho A^t A)
C
C     for matrix
C
C         H = B + S + rho A^t A,
C
C     where E is the spectral correction of diag(rho A^t A) and Q is
C     the BFGS correction of (E + diag(rho A^t A)), while S and B are
C     the spectral and BFGS corrections of matrix (rho A^t A),
C     respectively.
C
C     This subroutine computes:
C
C     (a) pdiag = diag(rho A^t A),
C
C     (b) plspg such that E = plspg I,
C
C     (c) psmdy = s - D^-1 y, where D = E + diag(rho A^t A), and
C
C     (d) the inner product psmdty = <psmdy,y>.
C
C     These quantities will be used later, in subroutine applyp, to
C     compute z = P^{-1} r.

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      double precision bignum,macheps,macheps12,macheps13,macheps23

C     COMMON BLOCKS
      common /machcon/ bignum,macheps,macheps12,macheps13,macheps23
      save   /machcon/
C     PARAMETERS

C     General constants

      double precision fmin

      parameter ( fmin       = - 1.0d+20 )

C     Line search constants

      integer maxextrap,mininterp
      double precision beta,etaint,etaext,gamma,sigma1,sigma2

      parameter ( maxextrap  =       100 )
      parameter ( mininterp  =         4 )

      parameter ( gamma      =   1.0d-04 )
      parameter ( beta       =     0.5d0 )
      parameter ( sigma1     =     0.1d0 )
      parameter ( sigma2     =     0.9d0 )
      parameter ( etaint     =     2.0d0 )
      parameter ( etaext     =     2.0d0 )

C     Safeguarding spectral step constants

      double precision lspgma,lspgmi

      parameter ( lspgma     =   1.0d+10 )
      parameter ( lspgmi     =   1.0d-10 )

C     Conjugate gradients constants

      integer maxcgitnp
      double precision epsnqmp,theta

      parameter ( theta      =   1.0d-06 )
      parameter ( epsnqmp    =   1.0d-08 )
      parameter ( maxcgitnp  =         5 )

C     BETRA constants

      logical extrp4,extrp5
      integer msmaxit
      double precision mseps,msrho,mssig,phieps,trdelini,trdelmin,
     +        tralpha

      parameter ( extrp4     =   .true. )
      parameter ( extrp5     =   .true. )

      parameter ( msmaxit    =       20 )

      parameter ( mseps      =  1.0d-08 )
      parameter ( mssig      =  1.0d-01 )
      parameter ( msrho      =  9.0d-01 )
      parameter ( phieps     =  1.0d-08 )
      parameter ( trdelini   =  1.0d+02 )
      parameter ( trdelmin   =  1.0d-08 )
      parameter ( tralpha    =  1.0d-01 )

C     GENCAN constants

      integer maxinnitnp
      double precision cggpnf,cgepsi,cgepsf,delmin,eta

      parameter ( maxinnitnp =         3 )
      parameter ( delmin     =   1.0d+04 )
      parameter ( eta        =   0.1d0   )
      parameter ( cggpnf     =   1.0d-04 )
      parameter ( cgepsi     =   1.0d-01 )
      parameter ( cgepsf     =   1.0d-08 )

C     ALGENCAN constants

      logical rhorestart
      integer maxoutitnp,maxoutit
      double precision lammax,lammin,rhofrac,rhoinimax,rhoinimin,rhomax,
     +        rhomult

      parameter ( maxoutitnp =        10 )
      parameter ( maxoutit   =       100 )

      parameter ( lammin     = - 1.0d+20 )
      parameter ( lammax     =   1.0d+20 )

      parameter ( rhofrac    =   0.5d0   )
      parameter ( rhomult    =   1.0d+01 )
      parameter ( rhomax     =   1.0d+20 )

      parameter ( rhorestart =    .true. )
      parameter ( rhoinimin  =   1.0d-08 )
      parameter ( rhoinimax  =   1.0d+08 )
C     COMMON SCALARS
      logical constrc,gotc

C     COMMON ARRAYS
      integer jcvar(jcnnzmax),jcsta(mmax),jclen(mmax)
      double precision c(mmax),dpdc(mmax),g(nmax),gparc(nmax),
     +        jcval(jcnnzmax)

C     COMMON BLOCKS
      common /gdata/ g,gparc,c,dpdc,jcval,jcvar,jcsta,jclen,constrc,gotc
      save   /gdata/
C     COMMON SCALARS
      double precision seucn,sts,sty,yeucn

C     COMMON ARRAYS
      double precision s(nmax),y(nmax)

C     COMMON BLOCKS
      common /sydata/ s,y,seucn,yeucn,sts,sty
      save   /sydata/
C     COMMON SCALARS
      logical sameface
      integer ittype

C     COMMON BLOCKS
      common /itedat/ sameface,ittype
      save   /itedat/
C     COMMON SCALARS
      double precision plspg,psmdyty

C     COMMON ARRAYS
      double precision pdiag(nmax),psmdy(nmax)

C     COMMON BLOCKS
      common /hpredata/ pdiag,psmdy,plspg,psmdyty
      save   /hpredata/

C     LOCAL SCALARS
      integer i,j
      double precision sttmp

C     ------------------------------------------------------------------
C     Compute diag( rho A^t A )
C     ------------------------------------------------------------------

      do i = 1,n
          pdiag(i) = 0.0d0
      end do

      do j = 1,m
          if ( equatn(j) .or. dpdc(j) .gt. 0.0d0 ) then
              do i = jcsta(j),jcsta(j) + jclen(j) - 1
                  pdiag(jcvar(i)) =
     +            pdiag(jcvar(i)) + rho(j) * jcval(i) ** 2
              end do
          end if
      end do

C     ------------------------------------------------------------------
C     Compute plspg = s^t (y - diag( rho A^t A ) s) / (s^t s)
C     ------------------------------------------------------------------

      sttmp = 0.0d0
      do i = 1,n
          sttmp = sttmp + pdiag(i) * s(i) ** 2
      end do

      if ( sty - sttmp .le. 0.0d0 ) then
          plspg = lspgmi
      else
          plspg = max( lspgmi, min( ( sty - sttmp ) / sts, lspgma ) )
      end if

C     ------------------------------------------------------------------
C     Compute the BFGS correction Q of ( E + diag( rho A^t A ) )
C
C     Q = [ (s - D^-1 y) s^t + s (s - D^-1 y)^t ] / s^t y -
C         [ <s - D^-1 y, y> s s^t ] / (s^t y)^2,
C
C     where D = ( E + diag( rho A^t A ) )
C     ------------------------------------------------------------------

      if ( sameface .and. sty .gt. macheps12 * seucn * yeucn ) then

          psmdyty = 0.0d0
          do i = 1,n
              psmdy(i) = s(i) - y(i) / ( plspg + pdiag(i) )
              psmdyty = psmdyty + psmdy(i) * y(i)
          end do

      end if

      end

C     *****************************************************************
C     *****************************************************************

      subroutine applyhpre(n,m,rho,equatn,gotp,r,z)

      implicit none

C     SCALAR ARGUMENTS
      logical gotp
      integer m,n

C     ARRAY ARGUMENTS
      logical equatn(m)
      double precision r(n),rho(m),z(n)

C     This subroutine computes the product of the inverse of the matrix
C     computed by subroutine comphpre times vector r, i.e., z = P^{-1} r.

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      double precision bignum,macheps,macheps12,macheps13,macheps23

C     COMMON BLOCKS
      common /machcon/ bignum,macheps,macheps12,macheps13,macheps23
      save   /machcon/
C     COMMON SCALARS
      double precision seucn,sts,sty,yeucn

C     COMMON ARRAYS
      double precision s(nmax),y(nmax)

C     COMMON BLOCKS
      common /sydata/ s,y,seucn,yeucn,sts,sty
      save   /sydata/
C     COMMON SCALARS
      logical sameface
      integer ittype

C     COMMON BLOCKS
      common /itedat/ sameface,ittype
      save   /itedat/
C     COMMON SCALARS
      double precision plspg,psmdyty

C     COMMON ARRAYS
      double precision pdiag(nmax),psmdy(nmax)

C     COMMON BLOCKS
      common /hpredata/ pdiag,psmdy,plspg,psmdyty
      save   /hpredata/

C     LOCAL SCALARS
      integer i
      double precision c1,c2,psmdytr,str

C     ------------------------------------------------------------------
C     Compute P
C     ------------------------------------------------------------------

      if ( .not. gotp ) then
          gotp = .true.
          call comphpre(n,m,rho,equatn)
      end if

C     ------------------------------------------------------------------
C     Compute ( E + diag( rho A^T A ) )^{-1} r
C     ------------------------------------------------------------------

      do i = 1,n
          z(i) = r(i) / ( plspg + pdiag(i) )
      end do

C     ------------------------------------------------------------------
C     Add Q^{-1} r, where
C
C     Q^{-1} = [ (s - D^-1 y) s^t + s (s - D^-1 y)^t ] / s^t y -
C              [ <s - D^-1 y, y> s s^t ] / (s^t y)^2
C
C     and D = ( E + diag( rho A^T A ) )
C     ------------------------------------------------------------------

      if ( sameface .and. sty .gt. macheps12 * seucn * yeucn ) then

          str = 0.0d0
          psmdytr = 0.0d0
          do i = 1,n
              str = str + s(i) * r(i)
              psmdytr = psmdytr + psmdy(i) * r(i)
          end do

          c1 = str / sty
          c2 = psmdytr / sty - psmdyty * str / sty ** 2

          do i = 1,n
              z(i) = z(i) + c1 * psmdy(i) + c2 * s(i)
          end do

      end if

      end
C     SCALE OBJECTIVE FUNCTION AND CONSTRAINTS

C     ******************************************************************
C     ******************************************************************

      subroutine sinip(n,x,l,u,m,lambda,equatn,linear,coded,checkder,
     +inform)

      implicit none

C     SCALAR ARGUMENTS
      logical checkder
      integer inform,m,n

C     ARRAY ARGUMENTS
      logical coded(10),equatn(m),linear(m)
      double precision l(n),lambda(m),u(n),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical iprintctl(7)
      integer iprintinn,iprintout,mprint,nprint

C     COMMON BLOCKS
      common /outdat/ iprintctl,iprintinn,iprintout,nprint,mprint
      save   /outdat/

C     COMMON SCALARS
      logical scale
      double precision sf,usf

C     COMMON ARRAYS
      double precision sc(mmax),usc(mmax)

C     COMMON BLOCK
      common /scadat/ sc,usc,sf,usf,scale
      save   /scadat/
C     COMMON SCALARS
      character * 6 hptype
      character * 2 innslvr
      logical ccoded,fccoded,fcoded,gcoded,gjaccoded,innercall,jaccoded,
     +        hcoded,hccoded,hlcoded,hlpcoded,firstde,truehl,ignoref,
     +        skipacc,sclsys,useustp,safemode

C     COMMON BLOCKS
      common /algparam/ fcoded,gcoded,hcoded,ccoded,jaccoded,hccoded,
     +                  hlcoded,hlpcoded,fccoded,gjaccoded,firstde,
     +                  truehl,ignoref,skipacc,sclsys,innercall,useustp,
     +                  innslvr,hptype,safemode
      save   /algparam/
C     COMMON SCALARS
      double precision bignum,macheps,macheps12,macheps13,macheps23

C     COMMON BLOCKS
      common /machcon/ bignum,macheps,macheps12,macheps13,macheps23
      save   /machcon/
C     COMMON SCALARS
      integer nbds

C     COMMON BLOCKS
      common /probdata/ nbds
      save   /probdata/

C     LOCAL SCALARS
      integer i,fun,j,jcnnz,neq
      double precision scmin

C     LOCAL ARRAYS
      integer jcfun(jcnnzmax),jcvar(jcnnzmax)
      double precision g(nmax),jcval(jcnnzmax)

      neq = 0
      do j = 1,m
          if ( equatn(j) ) neq = neq + 1
      end do

      nbds = 0
      do i = 1,n
          if ( l(i) .gt. - 1.0d+20 ) nbds = nbds + 1
          if ( u(i) .lt.   1.0d+20 ) nbds = nbds + 1
      end do

      if ( iprintctl(2) ) then
          write(* ,100) n,neq,m-neq,nbds
          write(10,100) n,neq,m-neq,nbds
      end if

      call tinip(n,x,l,u,m,lambda,equatn,linear,coded,checkder,inform)
      if ( inform .lt. 0 ) return

C     Write classification line of final model

      if ( iprintctl(6) ) then
          open(50,file='class-tabline.out')
          write(50,400) n,neq,m-neq,nbds
          close(50)
      end if

C     Scaling

      usf = 1.0d0
      do j = 1,m
          usc(j) = 1.0d0
      end do

      if ( scale ) then

          if ( m .eq. 0 ) then
              sf = 1.0d0
              if ( iprintctl(2) ) then
                  write(* ,200) sf
                  write(10,200) sf
              end if

              return
          end if

          call tsetp(n,x)

          if ( gjaccoded ) then

              call tevalgjac(n,x,g,m,jcfun,jcvar,jcval,jcnnz,inform)
              if ( inform .lt. 0 ) return

C             Scale constraints

              do j = 1,m
                  sc(j) = 1.0d0
              end do

              do i = 1,jcnnz
                  fun = jcfun(i)
                  sc(fun) = max( sc(fun), abs( jcval(i) ) )
              end do

              do j = 1,m
                  sc(j) = 1.0d0 / sc(j)
              end do

          else

              call tevalg(n,x,g,inform)
              if ( inform .lt. 0 ) return

C             Scale constraints

              do j = 1,m
                  call tevaljac(n,x,j,jcvar,jcval,jcnnz,inform)
                  if ( inform .lt. 0 ) return

                  sc(j) = 1.0d0
                  do i = 1,jcnnz
                      sc(j) = max( sc(j), abs( jcval(i) ) )
                  end do
                  sc(j) = 1.0d0 / sc(j)
              end do

          end if

C         Scale objective function

          sf = 1.0d0
          do i = 1,n
              sf = max( sf, abs( g(i) ) )
          end do
          sf = 1.0d0 / sf

C         Report scaling factors

          scmin = bignum
          do j = 1,m
              scmin = min( scmin, sc(j) )
          end do

          if ( iprintctl(2) ) then
              write(* ,300) sf,scmin
              write(10,300) sf,scmin
          end if
      end if

C     NON-EXECUTABLE STATEMENTS

 100  format(/,1X,'Number of variables               : ',I7,
     +       /,1X,'Number of equality constraints    : ',I7,
     +       /,1X,'Number of inequality constraints  : ',I7,
     +       /,1X,'Number of bound constraints       : ',I7)

 200  format(/,1X,'Objective function scale factor   : ',1P,D7.1,
     +       /,1X,'The scaling feature was mainly developed for ',
     +            'constrained problems. For',/,1X,'unconstrained and ',
     +            'bound-constrained problem, please, set the ',
     +            'optimality',/,1X,'tolerance (related to the ',
     +            'sup-norm of the projected gradient of the',/,1X,
     +            'objective function) with a convenient value.')

 300  format(/,1X,'Objective function scale factor   : ',1P,D7.1,
     +       /,1X,'Smallest constraints scale factor : ',1P,D7.1)

 400  format(  1X,I6,1X,I6,1X,I6,1X,I6)

      end

C     ******************************************************************
C     ******************************************************************

      subroutine sendp(n,x,l,u,m,lambda,equatn,linear,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,m,n

C     ARRAY ARGUMENTS
      logical equatn(m),linear(m)
      double precision l(n),lambda(m),u(n),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical scale
      double precision sf,usf

C     COMMON ARRAYS
      double precision sc(mmax),usc(mmax)

C     COMMON BLOCK
      common /scadat/ sc,usc,sf,usf,scale
      save   /scadat/

C     LOCAL SCALARS
      integer i

      if ( scale ) then
          do i = 1,m
              lambda(i) = lambda(i) * sc(i) / sf
          end do

          scale = .false.
      end if

      call tendp(n,x,l,u,m,lambda,equatn,linear,inform)
      if ( inform .lt. 0 ) return

      end

C     *****************************************************************
C     *****************************************************************

      subroutine sevalobjc(n,x,f,fu,m,c,cu,inform)

      implicit none

C     SCALAR ARGUMENTS
      double precision f,fu
      integer inform,m,n

C     ARRAY ARGUMENTS
      double precision c(m),cu(m),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical scale
      double precision sf,usf

C     COMMON ARRAYS
      double precision sc(mmax),usc(mmax)

C     COMMON BLOCK
      common /scadat/ sc,usc,sf,usf,scale
      save   /scadat/
C     COMMON SCALARS
      character * 6 hptype
      character * 2 innslvr
      logical ccoded,fccoded,fcoded,gcoded,gjaccoded,innercall,jaccoded,
     +        hcoded,hccoded,hlcoded,hlpcoded,firstde,truehl,ignoref,
     +        skipacc,sclsys,useustp,safemode

C     COMMON BLOCKS
      common /algparam/ fcoded,gcoded,hcoded,ccoded,jaccoded,hccoded,
     +                  hlcoded,hlpcoded,fccoded,gjaccoded,firstde,
     +                  truehl,ignoref,skipacc,sclsys,innercall,useustp,
     +                  innslvr,hptype,safemode
      save   /algparam/

C     LOCAL SCALARS
      integer j

      if ( fcoded .and. ( ccoded .or. m .eq. 0 ) ) then

          if ( ignoref ) then
              fu = 0.0d0
          else
              call tevalf(n,x,fu,inform)
              if ( inform .lt. 0 ) return
          end if

          do j = 1,m
              call tevalc(n,x,j,cu(j),inform)
              if ( inform .lt. 0 ) return
          end do

      else ! if ( fccoded ) then
          call tevalfc(n,x,fu,m,cu,inform)
          if ( inform .lt. 0 ) return

          if ( ignoref ) fu = 0.0d0
      end if

      if ( scale ) then
          f = fu * sf

          do j = 1,m
              c(j) = cu(j) * sc(j)
          end do

      else
          f = fu

          do j = 1,m
              c(j) = cu(j)
          end do
      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine sevalf(n,x,f,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,n
      double precision f

C     ARRAY ARGUMENTS
      double precision x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical scale
      double precision sf,usf

C     COMMON ARRAYS
      double precision sc(mmax),usc(mmax)

C     COMMON BLOCK
      common /scadat/ sc,usc,sf,usf,scale
      save   /scadat/
C     COMMON SCALARS
      character * 6 hptype
      character * 2 innslvr
      logical ccoded,fccoded,fcoded,gcoded,gjaccoded,innercall,jaccoded,
     +        hcoded,hccoded,hlcoded,hlpcoded,firstde,truehl,ignoref,
     +        skipacc,sclsys,useustp,safemode

C     COMMON BLOCKS
      common /algparam/ fcoded,gcoded,hcoded,ccoded,jaccoded,hccoded,
     +                  hlcoded,hlpcoded,fccoded,gjaccoded,firstde,
     +                  truehl,ignoref,skipacc,sclsys,innercall,useustp,
     +                  innslvr,hptype,safemode
      save   /algparam/

      if ( ignoref ) then
          f = 0.0d0
          return
      end if

      call tevalf(n,x,f,inform)
      if ( inform .lt. 0 ) return

      if ( scale ) f = f * sf

      end

C     ******************************************************************
C     ******************************************************************

      subroutine sevalg(n,x,g,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,n

C     ARRAY ARGUMENTS
      double precision g(n),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical scale
      double precision sf,usf

C     COMMON ARRAYS
      double precision sc(mmax),usc(mmax)

C     COMMON BLOCK
      common /scadat/ sc,usc,sf,usf,scale
      save   /scadat/
C     COMMON SCALARS
      character * 6 hptype
      character * 2 innslvr
      logical ccoded,fccoded,fcoded,gcoded,gjaccoded,innercall,jaccoded,
     +        hcoded,hccoded,hlcoded,hlpcoded,firstde,truehl,ignoref,
     +        skipacc,sclsys,useustp,safemode

C     COMMON BLOCKS
      common /algparam/ fcoded,gcoded,hcoded,ccoded,jaccoded,hccoded,
     +                  hlcoded,hlpcoded,fccoded,gjaccoded,firstde,
     +                  truehl,ignoref,skipacc,sclsys,innercall,useustp,
     +                  innslvr,hptype,safemode
      save   /algparam/

C     LOCAL SCALARS
      integer i

      if ( ignoref ) then
          do i = 1,n
              g(i) = 0.0d0
          end do
          return
      end if

      call tevalg(n,x,g,inform)
      if ( inform .lt. 0 ) return

      if ( scale ) then
          do i = 1,n
              g(i) = g(i) * sf
          end do
      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine sevalh(n,x,hlin,hcol,hval,hnnz,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,n,hnnz

C     ARRAY ARGUMENTS
      integer hcol(*),hlin(*)
      double precision hval(*),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical scale
      double precision sf,usf

C     COMMON ARRAYS
      double precision sc(mmax),usc(mmax)

C     COMMON BLOCK
      common /scadat/ sc,usc,sf,usf,scale
      save   /scadat/
C     COMMON SCALARS
      character * 6 hptype
      character * 2 innslvr
      logical ccoded,fccoded,fcoded,gcoded,gjaccoded,innercall,jaccoded,
     +        hcoded,hccoded,hlcoded,hlpcoded,firstde,truehl,ignoref,
     +        skipacc,sclsys,useustp,safemode

C     COMMON BLOCKS
      common /algparam/ fcoded,gcoded,hcoded,ccoded,jaccoded,hccoded,
     +                  hlcoded,hlpcoded,fccoded,gjaccoded,firstde,
     +                  truehl,ignoref,skipacc,sclsys,innercall,useustp,
     +                  innslvr,hptype,safemode
      save   /algparam/

C     LOCAL SCALARS
      integer i

      if ( ignoref ) then
          hnnz = 0
          return
      end if

      call tevalh(n,x,hlin,hcol,hval,hnnz,inform)
      if ( inform .lt. 0 ) return

      if ( scale ) then
          do i = 1,hnnz
              hval(i) = hval(i) * sf
          end do
      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine sevalc(n,x,ind,c,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer ind,inform,n
      double precision c

C     ARRAY ARGUMENTS
      double precision x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical scale
      double precision sf,usf

C     COMMON ARRAYS
      double precision sc(mmax),usc(mmax)

C     COMMON BLOCK
      common /scadat/ sc,usc,sf,usf,scale
      save   /scadat/

      call tevalc(n,x,ind,c,inform)
      if ( inform .lt. 0 ) return

      if ( scale ) c = c * sc(ind)

      end

C     ******************************************************************
C     ******************************************************************

      subroutine sevaljac(n,x,ind,jcvar,jcval,jcnnz,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,ind,n,jcnnz

C     ARRAY ARGUMENTS
      integer jcvar(n)
      double precision x(n),jcval(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical scale
      double precision sf,usf

C     COMMON ARRAYS
      double precision sc(mmax),usc(mmax)

C     COMMON BLOCK
      common /scadat/ sc,usc,sf,usf,scale
      save   /scadat/

C     LOCAL SCALARS
      integer i

      call tevaljac(n,x,ind,jcvar,jcval,jcnnz,inform)
      if ( inform .lt. 0 ) return

      if ( scale ) then
          do i = 1,jcnnz
              jcval(i) = jcval(i) * sc(ind)
          end do
      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine sevalhc(n,x,ind,hlin,hcol,hval,hnnz,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,ind,n,hnnz

C     ARRAY ARGUMENTS
      integer hcol(*),hlin(*)
      double precision hval(*),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical scale
      double precision sf,usf

C     COMMON ARRAYS
      double precision sc(mmax),usc(mmax)

C     COMMON BLOCK
      common /scadat/ sc,usc,sf,usf,scale
      save   /scadat/

C     LOCAL SCALARS
      integer i

      call tevalhc(n,x,ind,hlin,hcol,hval,hnnz,inform)
      if ( inform .lt. 0 ) return

      if ( scale ) then
          do i = 1,hnnz
              hval(i) = hval(i) * sc(ind)
          end do
      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine sevalhl(n,x,m,lambda,hlin,hcol,hval,hnnz,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer hnnz,inform,m,n

C     ARRAY ARGUMENTS
      integer hlin(*),hcol(*)
      double precision hval(*),lambda(m),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical scale
      double precision sf,usf

C     COMMON ARRAYS
      double precision sc(mmax),usc(mmax)

C     COMMON BLOCK
      common /scadat/ sc,usc,sf,usf,scale
      save   /scadat/
C     COMMON SCALARS
      character * 6 hptype
      character * 2 innslvr
      logical ccoded,fccoded,fcoded,gcoded,gjaccoded,innercall,jaccoded,
     +        hcoded,hccoded,hlcoded,hlpcoded,firstde,truehl,ignoref,
     +        skipacc,sclsys,useustp,safemode

C     COMMON BLOCKS
      common /algparam/ fcoded,gcoded,hcoded,ccoded,jaccoded,hccoded,
     +                  hlcoded,hlpcoded,fccoded,gjaccoded,firstde,
     +                  truehl,ignoref,skipacc,sclsys,innercall,useustp,
     +                  innslvr,hptype,safemode
      save   /algparam/

C     LOCAL SCALARS
      double precision tsf

      if ( scale ) then
          if ( ignoref ) then
              tsf = 0.0d0
          else
              tsf = sf
          end if

          call tevalhl(n,x,m,lambda,tsf,sc,hlin,hcol,hval,hnnz,inform)
          if ( inform .lt. 0 ) return

      else
          if ( ignoref ) then
              tsf = 0.0d0
          else
              tsf = usf
          end if

          call tevalhl(n,x,m,lambda,tsf,usc,hlin,hcol,hval,hnnz,inform)
          if ( inform .lt. 0 ) return
      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine sevalhlp(n,x,m,lambda,p,hp,gothl,inform)

      implicit none

C     SCALAR ARGUMENTS
      logical gothl
      integer inform,m,n

C     ARRAY ARGUMENTS
      double precision hp(n),lambda(m),p(n),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical scale
      double precision sf,usf

C     COMMON ARRAYS
      double precision sc(mmax),usc(mmax)

C     COMMON BLOCK
      common /scadat/ sc,usc,sf,usf,scale
      save   /scadat/
C     COMMON SCALARS
      character * 6 hptype
      character * 2 innslvr
      logical ccoded,fccoded,fcoded,gcoded,gjaccoded,innercall,jaccoded,
     +        hcoded,hccoded,hlcoded,hlpcoded,firstde,truehl,ignoref,
     +        skipacc,sclsys,useustp,safemode

C     COMMON BLOCKS
      common /algparam/ fcoded,gcoded,hcoded,ccoded,jaccoded,hccoded,
     +                  hlcoded,hlpcoded,fccoded,gjaccoded,firstde,
     +                  truehl,ignoref,skipacc,sclsys,innercall,useustp,
     +                  innslvr,hptype,safemode
      save   /algparam/

C     LOCAL SCALARS
      double precision tsf

      if ( scale ) then
          if ( ignoref ) then
              tsf = 0.0d0
          else
              tsf = sf
          end if

          call tevalhlp(n,x,m,lambda,tsf,sc,p,hp,gothl,inform)
          if ( inform .lt. 0 ) return

      else
          if ( ignoref ) then
              tsf = 0.0d0
          else
              tsf = usf
          end if

          call tevalhlp(n,x,m,lambda,tsf,usc,p,hp,gothl,inform)
          if ( inform .lt. 0 ) return
      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine sevalfc(n,x,f,m,c,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,m,n
      double precision f

C     ARRAY ARGUMENTS
      double precision c(m),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical scale
      double precision sf,usf

C     COMMON ARRAYS
      double precision sc(mmax),usc(mmax)

C     COMMON BLOCK
      common /scadat/ sc,usc,sf,usf,scale
      save   /scadat/
C     COMMON SCALARS
      character * 6 hptype
      character * 2 innslvr
      logical ccoded,fccoded,fcoded,gcoded,gjaccoded,innercall,jaccoded,
     +        hcoded,hccoded,hlcoded,hlpcoded,firstde,truehl,ignoref,
     +        skipacc,sclsys,useustp,safemode

C     COMMON BLOCKS
      common /algparam/ fcoded,gcoded,hcoded,ccoded,jaccoded,hccoded,
     +                  hlcoded,hlpcoded,fccoded,gjaccoded,firstde,
     +                  truehl,ignoref,skipacc,sclsys,innercall,useustp,
     +                  innslvr,hptype,safemode
      save   /algparam/

C     LOCAL SCALARS
      integer j

      call tevalfc(n,x,f,m,c,inform)
      if ( inform .lt. 0 ) return

      if ( ignoref ) f = 0.0d0

      if ( scale ) then
          f = f * sf

          do j = 1,m
              c(j) = c(j) * sc(j)
          end do
      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine sevalgjac(n,x,g,m,jcfun,jcvar,jcval,jcnnz,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,jcnnz,m,n

C     ARRAY ARGUMENTS
      integer jcfun(*),jcvar(*)
      double precision g(n),jcval(*),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical scale
      double precision sf,usf

C     COMMON ARRAYS
      double precision sc(mmax),usc(mmax)

C     COMMON BLOCK
      common /scadat/ sc,usc,sf,usf,scale
      save   /scadat/
C     COMMON SCALARS
      character * 6 hptype
      character * 2 innslvr
      logical ccoded,fccoded,fcoded,gcoded,gjaccoded,innercall,jaccoded,
     +        hcoded,hccoded,hlcoded,hlpcoded,firstde,truehl,ignoref,
     +        skipacc,sclsys,useustp,safemode

C     COMMON BLOCKS
      common /algparam/ fcoded,gcoded,hcoded,ccoded,jaccoded,hccoded,
     +                  hlcoded,hlpcoded,fccoded,gjaccoded,firstde,
     +                  truehl,ignoref,skipacc,sclsys,innercall,useustp,
     +                  innslvr,hptype,safemode
      save   /algparam/

C     LOCAL SCALARS
      integer i

      call tevalgjac(n,x,g,m,jcfun,jcvar,jcval,jcnnz,inform)
      if ( inform .lt. 0 ) return

      if ( ignoref ) then
          do i = 1,n
              g(i) = 0.0d0
          end do
      end if

      if ( scale ) then
          do i = 1,n
              g(i) = g(i) * sf
          end do

          do i = 1,jcnnz
              jcval(i) = jcval(i) * sc(jcfun(i))
          end do
      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine ssetp(n,x)

      implicit none

C     SCALAR ARGUMENTS
      integer n

C     ARRAY ARGUMENTS
      double precision x(n)

      call tsetp(n,x)

      end

C     ******************************************************************
C     ******************************************************************

      subroutine sunsetp()

      implicit none

      call tunsetp()

      end
C     ADD SLACKS

C     ******************************************************************
C     ******************************************************************

      subroutine tinip(n,x,l,u,m,lambda,equatn,linear,coded,checkder,
     +inform)

      implicit none

C     SCALAR ARGUMENTS
      logical checkder
      integer inform,m,n

C     ARRAY ARGUMENTS
      logical coded(10),equatn(m),linear(m)
      double precision l(n),lambda(m),u(n),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical slacks
      integer nws

C     COMMON ARRAYS
      integer slaind(mmax)

C     COMMON BLOCKS
      common /sladat/ slaind,nws,slacks
      save   /sladat/
C     COMMON SCALARS
      logical iprintctl(7)
      integer iprintinn,iprintout,mprint,nprint

C     COMMON BLOCKS
      common /outdat/ iprintctl,iprintinn,iprintout,nprint,mprint
      save   /outdat/

C     COMMON SCALARS
      character * 6 hptype
      character * 2 innslvr
      logical ccoded,fccoded,fcoded,gcoded,gjaccoded,innercall,jaccoded,
     +        hcoded,hccoded,hlcoded,hlpcoded,firstde,truehl,ignoref,
     +        skipacc,sclsys,useustp,safemode

C     COMMON BLOCKS
      common /algparam/ fcoded,gcoded,hcoded,ccoded,jaccoded,hccoded,
     +                  hlcoded,hlpcoded,fccoded,gjaccoded,firstde,
     +                  truehl,ignoref,skipacc,sclsys,innercall,useustp,
     +                  innslvr,hptype,safemode
      save   /algparam/

C     LOCAL SCALARS
      integer j
      double precision dum

C     LOCAL ARRAYS
      double precision c(mmax)

      call uinip(n,x,l,u,m,lambda,equatn,linear,coded,checkder,inform)
      if ( inform .lt. 0 ) return

      if ( slacks ) then

          nws = n

          call usetp(nws,x)

          if ( fccoded ) then
              call uevalfc(nws,x,dum,m,c,inform)
              if ( inform .lt. 0 ) return

          else
              do j = 1,m
                  if ( .not. equatn(j) ) then
                      call uevalc(nws,x,j,c(j),inform)
                      if ( inform .lt. 0 ) return
                  end if
              end do
          end if

          do j = 1,m
              if ( equatn(j) ) then
                  slaind(j) = - 1
              else
                  equatn(j) = .true.

                  n         = n + 1
                  slaind(j) = n

                  l(n)      = - 1.0d+20
                  u(n)      =   0.0d0
                  x(n)      = max( l(n), min( c(j), u(n) ) )
              end if
          end do

          if ( n .eq. nws ) slacks = .false.

          if ( iprintctl(2) ) then
              write(* ,100) n - nws
              write(10,100) n - nws
          end if
      end if

C     NON-EXECUTABLE STATEMENTS

 100  format(/,1X,'Number of added slack variables   : ',I7)

      end

C     ******************************************************************
C     ******************************************************************

      subroutine tendp(n,x,l,u,m,lambda,equatn,linear,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,m,n

C     ARRAY ARGUMENTS
      logical equatn(m),linear(m)
      double precision l(n),lambda(m),u(n),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical slacks
      integer nws

C     COMMON ARRAYS
      integer slaind(mmax)

C     COMMON BLOCKS
      common /sladat/ slaind,nws,slacks
      save   /sladat/

C     LOCAL SCALARS
      integer j

      if  ( slacks ) then
          n = nws

          do j = 1,m
              if ( slaind(j) .ne. - 1 ) then
                  equatn(j) = .false.
              end if
          end do

          slacks = .false.
      end if

      call uendp(n,x,l,u,m,lambda,equatn,linear,inform)
      if ( inform .lt. 0 ) return

      end

C     ******************************************************************
C     ******************************************************************

      subroutine tevalf(n,x,f,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,n
      double precision f

C     ARRAY ARGUMENTS
      double precision x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical slacks
      integer nws

C     COMMON ARRAYS
      integer slaind(mmax)

C     COMMON BLOCKS
      common /sladat/ slaind,nws,slacks
      save   /sladat/

      if ( .not. slacks ) then
          call uevalf(n,x,f,inform)
          if ( inform .lt. 0 ) return

      else
          call uevalf(nws,x,f,inform)
          if ( inform .lt. 0 ) return
      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine tevalg(n,x,g,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,n

C     ARRAY ARGUMENTS
      double precision g(n),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical slacks
      integer nws

C     COMMON ARRAYS
      integer slaind(mmax)

C     COMMON BLOCKS
      common /sladat/ slaind,nws,slacks
      save   /sladat/

C     LOCAL SCALARS
      integer i

      if ( .not. slacks ) then
          call uevalg(n,x,g,inform)
          if ( inform .lt. 0 ) return

      else
          call uevalg(nws,x,g,inform)
          if ( inform .lt. 0 ) return

          do i = nws + 1,n
              g(i) = 0.0d0
          end do
      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine tevalh(n,x,hlin,hcol,hval,hnnz,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,n,hnnz

C     ARRAY ARGUMENTS
      integer hcol(*),hlin(*)
      double precision hval(*),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical slacks
      integer nws

C     COMMON ARRAYS
      integer slaind(mmax)

C     COMMON BLOCKS
      common /sladat/ slaind,nws,slacks
      save   /sladat/

      if ( .not. slacks ) then
          call uevalh(n,x,hlin,hcol,hval,hnnz,inform)
          if ( inform .lt. 0 ) return

      else
          call uevalh(nws,x,hlin,hcol,hval,hnnz,inform)
          if ( inform .lt. 0 ) return
      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine tevalc(n,x,ind,c,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer ind,inform,n
      double precision c

C     ARRAY ARGUMENTS
      double precision x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical slacks
      integer nws

C     COMMON ARRAYS
      integer slaind(mmax)

C     COMMON BLOCKS
      common /sladat/ slaind,nws,slacks
      save   /sladat/

C     LOCAL SCALARS
      integer sind

      if ( .not. slacks ) then
          call uevalc(n,x,ind,c,inform)
          if ( inform .lt. 0 ) return

      else
          call uevalc(nws,x,ind,c,inform)
          if ( inform .lt. 0 ) return

          sind = slaind(ind)
          if ( sind .ne. - 1 ) c = c - x(sind)
      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine tevaljac(n,x,ind,jcvar,jcval,jcnnz,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,ind,n,jcnnz

C     ARRAY ARGUMENTS
      integer jcvar(n)
      double precision x(n),jcval(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical slacks
      integer nws

C     COMMON ARRAYS
      integer slaind(mmax)

C     COMMON BLOCKS
      common /sladat/ slaind,nws,slacks
      save   /sladat/

C     LOCAL SCALARS
      integer sind

      if ( .not. slacks ) then
          call uevaljac(n,x,ind,jcvar,jcval,jcnnz,inform)
          if ( inform .lt. 0 ) return

      else
          call uevaljac(nws,x,ind,jcvar,jcval,jcnnz,inform)
          if ( inform .lt. 0 ) return

          sind = slaind(ind)
          if ( sind .ne. - 1 ) then
              jcnnz = jcnnz +  1
              jcvar(jcnnz) = sind
              jcval(jcnnz) = - 1.0d0
          end if
      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine tevalhc(n,x,ind,hlin,hcol,hval,hnnz,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,ind,n,hnnz

C     ARRAY ARGUMENTS
      integer hcol(*),hlin(*)
      double precision hval(*),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical slacks
      integer nws

C     COMMON ARRAYS
      integer slaind(mmax)

C     COMMON BLOCKS
      common /sladat/ slaind,nws,slacks
      save   /sladat/

      if ( .not. slacks ) then
          call uevalhc(n,x,ind,hlin,hcol,hval,hnnz,inform)
          if ( inform .lt. 0 ) return

      else
          call uevalhc(nws,x,ind,hlin,hcol,hval,hnnz,inform)
          if ( inform .lt. 0 ) return
      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine tevalhl(n,x,m,lambda,sf,sc,hlin,hcol,hval,hnnz,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer hnnz,inform,m,n
      double precision sf

C     ARRAY ARGUMENTS
      integer hlin(*),hcol(*)
      double precision hval(*),lambda(m),sc(m),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical slacks
      integer nws

C     COMMON ARRAYS
      integer slaind(mmax)

C     COMMON BLOCKS
      common /sladat/ slaind,nws,slacks
      save   /sladat/

      if ( .not. slacks ) then
          call uevalhl(n,x,m,lambda,sf,sc,hlin,hcol,hval,hnnz,inform)
          if ( inform .lt. 0 ) return

      else
          call uevalhl(nws,x,m,lambda,sf,sc,hlin,hcol,hval,hnnz,inform)
          if ( inform .lt. 0 ) return
      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine tevalhlp(n,x,m,lambda,sf,sc,p,hp,gothl,inform)

      implicit none

C     SCALAR ARGUMENTS
      logical gothl
      integer inform,m,n
      double precision sf

C     ARRAY ARGUMENTS
      double precision hp(n),lambda(m),p(n),sc(m),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical slacks
      integer nws

C     COMMON ARRAYS
      integer slaind(mmax)

C     COMMON BLOCKS
      common /sladat/ slaind,nws,slacks
      save   /sladat/

C     LOCAL SCALARS
      integer i

      if ( .not. slacks ) then
          call uevalhlp(n,x,m,lambda,sf,sc,p,hp,gothl,inform)
          if ( inform .lt. 0 ) return

      else
          call uevalhlp(nws,x,m,lambda,sf,sc,p,hp,gothl,inform)
          if ( inform .lt. 0 ) return

          do i = nws + 1,n
              hp(i) = 0.0d0
          end do
      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine tevalfc(n,x,f,m,c,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,m,n
      double precision f

C     ARRAY ARGUMENTS
      double precision c(m),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical slacks
      integer nws

C     COMMON ARRAYS
      integer slaind(mmax)

C     COMMON BLOCKS
      common /sladat/ slaind,nws,slacks
      save   /sladat/

C     LOCAL SCALARS
      integer j,sind

      if ( .not. slacks ) then
          call uevalfc(n,x,f,m,c,inform)
          if ( inform .lt. 0 ) return

      else
          call uevalfc(nws,x,f,m,c,inform)
          if ( inform .lt. 0 ) return

          do j = 1,m
              sind = slaind(j)
              if ( sind .ne. - 1 ) c(j) = c(j) - x(sind)
          end do
      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine tevalgjac(n,x,g,m,jcfun,jcvar,jcval,jcnnz,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,jcnnz,m,n

C     ARRAY ARGUMENTS
      integer jcfun(*),jcvar(*)
      double precision g(n),jcval(*),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical slacks
      integer nws

C     COMMON ARRAYS
      integer slaind(mmax)

C     COMMON BLOCKS
      common /sladat/ slaind,nws,slacks
      save   /sladat/

C     LOCAL SCALARS
      integer i,j,sind

      if ( .not. slacks ) then
          call uevalgjac(n,x,g,m,jcfun,jcvar,jcval,jcnnz,inform)
          if ( inform .lt. 0 ) return

      else
          call uevalgjac(nws,x,g,m,jcfun,jcvar,jcval,jcnnz,inform)
          if ( inform .lt. 0 ) return

          do i = nws + 1,n
              g(i) = 0.0d0
          end do

          do j = 1,m
              sind = slaind(j)
              if ( sind .ne. - 1 ) then
                  jcnnz = jcnnz +  1
                  jcfun(jcnnz) = j
                  jcvar(jcnnz) = sind
                  jcval(jcnnz) = - 1.0d0
              end if
          end do
      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine tsetp(n,x)

      implicit none

C     SCALAR ARGUMENTS
      integer n

C     ARRAY ARGUMENTS
      double precision x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical slacks
      integer nws

C     COMMON ARRAYS
      integer slaind(mmax)

C     COMMON BLOCKS
      common /sladat/ slaind,nws,slacks
      save   /sladat/

      if ( .not. slacks ) then
          call usetp(n,x)

      else
          call usetp(nws,x)
      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine tunsetp()

      implicit none

      call uunsetp()

      end
C     ADD REMOVED FIXED VARIABLES

C     ******************************************************************
C     ******************************************************************

      subroutine uinip(n,x,l,u,m,lambda,equatn,linear,coded,checkder,
     +inform)

      implicit none

C     SCALAR ARGUMENTS
      logical checkder
      integer inform,m,n

C     ARRAY ARGUMENTS
      logical coded(10),equatn(m),linear(m)
      double precision l(n),lambda(m),u(n),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      integer nbds

C     COMMON BLOCKS
      common /probdata/ nbds
      save   /probdata/
C     COMMON SCALARS
      logical rmfixv,yset

C     COMMON ARRAYS
      integer ycor(nmax),yind(0:nmax)
      double precision y(nmax)

C     COMMON BLOCKS
      common /fixvar/ y,ycor,yind,yset,rmfixv
      save   /fixvar/
C     COMMON SCALARS
      logical iprintctl(7)
      integer iprintinn,iprintout,mprint,nprint

C     COMMON BLOCKS
      common /outdat/ iprintctl,iprintinn,iprintout,nprint,mprint
      save   /outdat/


C     LOCAL SCALARS
      integer i

C     EXTERNAL SUBROUTINES
      external vinip

      call vinip(n,x,l,u,m,lambda,equatn,linear,coded,checkder,inform)
      if ( inform .lt. 0 ) return

C     Eliminate fixed variables (l=u) and save their values on y

      if ( rmfixv ) then

          yind(0) = n

          n = 0
          do i = 1,yind(0)
              if ( l(i) .lt. u(i) ) then
                  n = n + 1
                  yind(n) = i
                  ycor(i) = n
              else
                  y(i) = l(i)
                  ycor(i) = 0
              end if
          end do

          do i = 1,n
              x(i) = x(yind(i))
              l(i) = l(yind(i))
              u(i) = u(yind(i))
          end do

          if ( n .eq. yind(0) ) rmfixv = .false.

          if ( iprintctl(2) ) then
              write(* ,100) yind(0) - n
              write(10,100) yind(0) - n
          end if

          nbds = nbds - 2 * ( yind(0) - n )
      end if

C     NON-EXECUTABLE STATEMENTS

 100  format(/,1X,'Number of removed fixed variables : ',I7)

      end

C     ******************************************************************
C     ******************************************************************

      subroutine uendp(n,x,l,u,m,lambda,equatn,linear,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,m,n

C     ARRAY ARGUMENTS
      logical equatn(m),linear(m)
      double precision l(n),lambda(m),u(n),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical rmfixv,yset

C     COMMON ARRAYS
      integer ycor(nmax),yind(0:nmax)
      double precision y(nmax)

C     COMMON BLOCKS
      common /fixvar/ y,ycor,yind,yset,rmfixv
      save   /fixvar/

C     LOCAL SCALARS
      integer i,ind

C     EXTERNAL SUBROUTINES
      external vendp

C     Restore original x, l, u and n

      if ( rmfixv ) then
          do i = yind(0),1,-1
              ind = ycor(i)
              if ( ind .ne. 0 ) then
                  l(i) = l(ind)
                  u(i) = u(ind)
                  x(i) = x(ind)
              else
                  l(i) = y(i)
                  u(i) = y(i)
                  x(i) = y(i)
              end if
          end do

          n = yind(0)

          rmfixv = .false.
      end if

      call vendp(n,x,l,u,m,lambda,equatn,linear,inform)
      if ( inform .lt. 0 ) return

      end

C     ******************************************************************
C     ******************************************************************

      subroutine uevalf(n,x,f,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,n
      double precision f

C     ARRAY ARGUMENTS
      double precision x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical rmfixv,yset

C     COMMON ARRAYS
      integer ycor(nmax),yind(0:nmax)
      double precision y(nmax)

C     COMMON BLOCKS
      common /fixvar/ y,ycor,yind,yset,rmfixv
      save   /fixvar/

C     LOCAL SCALARS
      integer i

C     EXTERNAL SUBROUTINES
      external vevalf

      if ( .not. rmfixv ) then
          call vevalf(n,x,f,inform)
          if ( inform .lt. 0 ) return

      else
          if ( .not. yset ) then
              write(*,*) 'uevalf: Opa!!!!!!!!!!!!!!!!!!!!!!!!!'
              do i = 1,n
                  y(yind(i)) = x(i)
              end do
          end if

          call vevalf(yind(0),y,f,inform)
          if ( inform .lt. 0 ) return
      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine uevalg(n,x,g,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,n

C     ARRAY ARGUMENTS
      double precision g(n),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical rmfixv,yset

C     COMMON ARRAYS
      integer ycor(nmax),yind(0:nmax)
      double precision y(nmax)

C     COMMON BLOCKS
      common /fixvar/ y,ycor,yind,yset,rmfixv
      save   /fixvar/

C     LOCAL SCALARS
      integer i

C     EXTERNAL SUBROUTINES
      external vevalg

      if ( .not. rmfixv ) then
          call vevalg(n,x,g,inform)
          if ( inform .lt. 0 ) return

      else
          if ( .not. yset ) then
              write(*,*) 'uevalg: Opa!!!!!!!!!!!!!!!!!!!!!!!!!'
              do i = 1,n
                  y(yind(i)) = x(i)
              end do
          end if

          call vevalg(yind(0),y,g,inform)
          if ( inform .lt. 0 ) return

          do i = 1,n
              g(i) = g(yind(i))
          end do
      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine uevalh(n,x,hlin,hcol,hval,hnnz,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,n,hnnz

C     ARRAY ARGUMENTS
      integer hcol(*),hlin(*)
      double precision hval(*),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical rmfixv,yset

C     COMMON ARRAYS
      integer ycor(nmax),yind(0:nmax)
      double precision y(nmax)

C     COMMON BLOCKS
      common /fixvar/ y,ycor,yind,yset,rmfixv
      save   /fixvar/

C     LOCAL SCALARS
      integer col,i,j,lin

C     EXTERNAL SUBROUTINES
      external vevalh

      if ( .not. rmfixv ) then
          call vevalh(n,x,hlin,hcol,hval,hnnz,inform)
          if ( inform .lt. 0 ) return

      else
          if ( .not. yset ) then
              write(*,*) 'uevalh: Opa!!!!!!!!!!!!!!!!!!!!!!!!!'
              do i = 1,n
                  y(yind(i)) = x(i)
              end do
          end if

          call vevalh(yind(0),y,hlin,hcol,hval,hnnz,inform)
          if ( inform .lt. 0 ) return

          j = 0
          do i = 1,hnnz
              lin = ycor(hlin(i))
              col = ycor(hcol(i))
              if ( lin .ne. 0 .and. col .ne. 0 ) then
                  j = j + 1
                  hlin(j) = lin
                  hcol(j) = col
                  hval(j) = hval(i)
              end if
          end do

          hnnz = j
      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine uevalc(n,x,ind,c,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer ind,inform,n
      double precision c

C     ARRAY ARGUMENTS
      double precision x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical rmfixv,yset

C     COMMON ARRAYS
      integer ycor(nmax),yind(0:nmax)
      double precision y(nmax)

C     COMMON BLOCKS
      common /fixvar/ y,ycor,yind,yset,rmfixv
      save   /fixvar/

C     LOCAL SCALARS
      integer i

C     EXTERNAL SUBROUTINES
      external vevalc

      if ( .not. rmfixv ) then
          call vevalc(n,x,ind,c,inform)
          if ( inform .lt. 0 ) return

      else
          if ( .not. yset ) then
              write(*,*) 'uevalc: Opa!!!!!!!!!!!!!!!!!!!!!!!!!'
              do i = 1,n
                  y(yind(i)) = x(i)
              end do
          end if

          call vevalc(yind(0),y,ind,c,inform)
          if ( inform .lt. 0 ) return
      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine uevaljac(n,x,ind,jcvar,jcval,jcnnz,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,ind,n,jcnnz

C     ARRAY ARGUMENTS
      integer jcvar(n)
      double precision x(n),jcval(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical rmfixv,yset

C     COMMON ARRAYS
      integer ycor(nmax),yind(0:nmax)
      double precision y(nmax)

C     COMMON BLOCKS
      common /fixvar/ y,ycor,yind,yset,rmfixv
      save   /fixvar/

C     LOCAL SCALARS
      integer i,j,var

C     EXTERNAL SUBROUTINES
      external vevaljac

      if ( .not. rmfixv ) then
          call vevaljac(n,x,ind,jcvar,jcval,jcnnz,inform)
          if ( inform .lt. 0 ) return

      else
          if ( .not. yset ) then
              write(*,*) 'uevaljac: Opa!!!!!!!!!!!!!!!!!!!!!!!!!'
              do i = 1,n
                  y(yind(i)) = x(i)
              end do
          end if

          call vevaljac(yind(0),y,ind,jcvar,jcval,jcnnz,inform)
          if ( inform .lt. 0 ) return

          j = 0
          do i = 1,jcnnz
              var = ycor(jcvar(i))
              if ( var .ne. 0 ) then
                  j = j + 1
                  jcvar(j) = var
                  jcval(j) = jcval(i)
              end if
          end do

          jcnnz = j
      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine uevalhc(n,x,ind,hlin,hcol,hval,hnnz,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,ind,n,hnnz

C     ARRAY ARGUMENTS
      integer hcol(*),hlin(*)
      double precision hval(*),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical rmfixv,yset

C     COMMON ARRAYS
      integer ycor(nmax),yind(0:nmax)
      double precision y(nmax)

C     COMMON BLOCKS
      common /fixvar/ y,ycor,yind,yset,rmfixv
      save   /fixvar/

C     LOCAL SCALARS
      integer col,i,j,lin

C     EXTERNAL SUBROUTINES
      external vevalhc

      if ( .not. rmfixv ) then
          call vevalhc(n,x,ind,hlin,hcol,hval,hnnz,inform)
          if ( inform .lt. 0 ) return

      else
          if ( .not. yset ) then
              write(*,*) 'uevalhc: Opa!!!!!!!!!!!!!!!!!!!!!!!!!'
              do i = 1,n
                  y(yind(i)) = x(i)
              end do
          end if

          call vevalhc(yind(0),y,ind,hlin,hcol,hval,hnnz,inform)
          if ( inform .lt. 0 ) return

          j = 0
          do i = 1,hnnz
              lin = ycor(hlin(i))
              col = ycor(hcol(i))
              if ( lin .ne. 0 .and. col .ne. 0 ) then
                  j = j + 1
                  hlin(j) = lin
                  hcol(j) = col
                  hval(j) = hval(i)
              end if
          end do

          hnnz = j
      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine uevalhl(n,x,m,lambda,sf,sc,hlin,hcol,hval,hnnz,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer hnnz,inform,m,n
      double precision sf

C     ARRAY ARGUMENTS
      integer hlin(*),hcol(*)
      double precision hval(*),lambda(m),sc(m),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical rmfixv,yset

C     COMMON ARRAYS
      integer ycor(nmax),yind(0:nmax)
      double precision y(nmax)

C     COMMON BLOCKS
      common /fixvar/ y,ycor,yind,yset,rmfixv
      save   /fixvar/

C     LOCAL SCALARS
      integer col,i,j,lin

C     EXTERNAL SUBROUTINES
      external vevalhl

      if ( .not. rmfixv ) then
          call vevalhl(n,x,m,lambda,sf,sc,hlin,hcol,hval,hnnz,inform)
          if ( inform .lt. 0 ) return

      else
          if ( .not. yset ) then
              write(*,*) 'uevalhl: Opa!!!!!!!!!!!!!!!!!!!!!!!!!'
              do i = 1,n
                  y(yind(i)) = x(i)
              end do
          end if

          call vevalhl(yind(0),y,m,lambda,sf,sc,hlin,hcol,hval,hnnz,
     +    inform)
          if ( inform .lt. 0 ) return

          j = 0
          do i = 1,hnnz
              lin = ycor(hlin(i))
              col = ycor(hcol(i))
              if ( lin .ne. 0 .and. col .ne. 0 ) then
                  j = j + 1
                  hlin(j) = lin
                  hcol(j) = col
                  hval(j) = hval(i)
              end if
          end do

          hnnz = j
      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine uevalhlp(n,x,m,lambda,sf,sc,p,hp,gothl,inform)

      implicit none

C     SCALAR ARGUMENTS
      logical gothl
      integer inform,m,n
      double precision sf

C     ARRAY ARGUMENTS
      double precision hp(n),lambda(m),p(n),sc(m),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical rmfixv,yset

C     COMMON ARRAYS
      integer ycor(nmax),yind(0:nmax)
      double precision y(nmax)

C     COMMON BLOCKS
      common /fixvar/ y,ycor,yind,yset,rmfixv
      save   /fixvar/

C     LOCAL SCALARS
      integer i

C     LOCAL ARRAYS
      double precision w(nmax)

C     EXTERNAL SUBROUTINES
      external vevalhlp

      if ( .not. rmfixv ) then
          call vevalhlp(n,x,m,lambda,sf,sc,p,hp,gothl,inform)
          if ( inform .lt. 0 ) return

      else
          if ( .not. yset ) then
              write(*,*) 'uevalhlp: Opa!!!!!!!!!!!!!!!!!!!!!!!!!'
              do i = 1,n
                  y(yind(i)) = x(i)
              end do
          end if

          do i = 1,yind(0)
              w(i) = 0.0d0
          end do

          do i = 1,n
              w(yind(i)) = p(i)
          end do

          call vevalhlp(yind(0),y,m,lambda,sf,sc,w,hp,gothl,inform)
          if ( inform .lt. 0 ) return

          do i = 1,n
              hp(i) = hp(yind(i))
          end do
      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine uevalfc(n,x,f,m,c,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,m,n
      double precision f

C     ARRAY ARGUMENTS
      double precision c(m),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical rmfixv,yset

C     COMMON ARRAYS
      integer ycor(nmax),yind(0:nmax)
      double precision y(nmax)

C     COMMON BLOCKS
      common /fixvar/ y,ycor,yind,yset,rmfixv
      save   /fixvar/

C     LOCAL SCALARS
      integer i

C     EXTERNAL SUBROUTINES
      external vevalfc

      if ( .not. rmfixv ) then
          call vevalfc(n,x,f,m,c,inform)
          if ( inform .lt. 0 ) return

      else
          if ( .not. yset ) then
              write(*,*) 'uevalfc: Opa!!!!!!!!!!!!!!!!!!!!!!!!!'
              do i = 1,n
                  y(yind(i)) = x(i)
              end do
          end if

          call vevalfc(yind(0),y,f,m,c,inform)
          if ( inform .lt. 0 ) return
      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine uevalgjac(n,x,g,m,jcfun,jcvar,jcval,jcnnz,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,jcnnz,m,n

C     ARRAY ARGUMENTS
      integer jcfun(*),jcvar(*)
      double precision g(n),jcval(*),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical rmfixv,yset

C     COMMON ARRAYS
      integer ycor(nmax),yind(0:nmax)
      double precision y(nmax)

C     COMMON BLOCKS
      common /fixvar/ y,ycor,yind,yset,rmfixv
      save   /fixvar/

C     LOCAL SCALARS
      integer i,j,var

C     EXTERNAL SUBROUTINES
      external vevalgjac

      if ( .not. rmfixv ) then
          call vevalgjac(n,x,g,m,jcfun,jcvar,jcval,jcnnz,inform)
          if ( inform .lt. 0 ) return

      else
          if ( .not. yset ) then
              write(*,*) 'uevalgjac: Opa!!!!!!!!!!!!!!!!!!!!!!!!!'
              do i = 1,n
                  y(yind(i)) = x(i)
              end do
          end if

          call vevalgjac(yind(0),y,g,m,jcfun,jcvar,jcval,jcnnz,inform)
          if ( inform .lt. 0 ) return

          do i = 1,n
              g(i) = g(yind(i))
          end do

          j = 0
          do i = 1,jcnnz
              var = ycor(jcvar(i))
              if ( var .ne. 0 ) then
                  j = j + 1
                  jcfun(j) = jcfun(i)
                  jcvar(j) = var
                  jcval(j) = jcval(i)
              end if
          end do

          jcnnz = j
      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine usetp(n,x)

      implicit none

C     SCALAR ARGUMENTS
      integer n

C     ARRAY ARGUMENTS
      double precision x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical rmfixv,yset

C     COMMON ARRAYS
      integer ycor(nmax),yind(0:nmax)
      double precision y(nmax)

C     COMMON BLOCKS
      common /fixvar/ y,ycor,yind,yset,rmfixv
      save   /fixvar/

C     LOCAL SCALARS
      integer i

C     EXTERNAL SUBROUTINES
      external vsetp

      if ( .not. rmfixv ) then
          call vsetp(n,x)
          return
      end if

      yset = .true.

      do i = 1,n
          y(yind(i)) = x(i)
      end do

      call vsetp(yind(0),y)

      end

C     ******************************************************************
C     ******************************************************************

      subroutine uunsetp()

      implicit none

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical rmfixv,yset

C     COMMON ARRAYS
      integer ycor(nmax),yind(0:nmax)
      double precision y(nmax)

C     COMMON BLOCKS
      common /fixvar/ y,ycor,yind,yset,rmfixv
      save   /fixvar/

C     EXTERNAL SUBROUTINES
      external vunsetp

      yset = .false.

      call vunsetp()

      end
C     SAFE CALL TO THE USER PROVIDED SUBROUTINES

C     ******************************************************************
C     ******************************************************************

      subroutine vinip(n,x,l,u,m,lambda,equatn,linear,coded,checkder,
     +inform)

      implicit none

C     SCALAR ARGUMENTS
      logical checkder
      integer inform,m,n

C     ARRAY ARGUMENTS
      logical coded(6),equatn(m),linear(m)
      double precision l(n),lambda(m),u(n),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )

C     LOCAL SCALARS
      integer i

C     INTRINSEC FUNCTIONS
      intrinsic max,min

C     EXTERNAL SUBROUTINES
      external checkd

C     Avoid huge bounds

      do i = 1,n
          l(i) = max( l(i), - 1.0d+20 )
          u(i) = min( u(i),   1.0d+20 )
      end do

C     Project initial guess

      do i = 1,n
          x(i) = max( l(i), min( x(i), u(i) ) )
      end do

C     Check derivatives

      if ( checkder ) then
          call checkd(n,l,u,m,inform)
          if ( inform .lt. 0 ) return
      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine vendp(n,x,l,u,m,lambda,equatn,linear,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,m,n

C     ARRAY ARGUMENTS
      logical equatn(m),linear(m)
      double precision l(n),lambda(m),u(n),x(n)

C     COMMON SCALARS
      logical iprintctl(7)
      integer iprintinn,iprintout,mprint,nprint

C     COMMON BLOCKS
      common /outdat/ iprintctl,iprintinn,iprintout,nprint,mprint
      save   /outdat/


C     LOCAL SCALARS
      integer i

      if ( iprintctl(2) ) then

C         Save solution

          open(20,file='solution.txt')

C         Point

          write(20,100)
          do i = 1,n
              write(20,200) i,x(i)
          end do

C         Lagrange multipliers

          if ( m .gt. 0 ) then
              write(20,300)
              do i = 1,m
                  write(20,200) i,lambda(i)
              end do
          end if

          close(20)

      end if

C     NON-EXECUTABLE STATEMENTS

 100  format(/,'FINAL POINT:',//,2X,'INDEX',16X,'X(INDEX)')
 200  format(I7,1P,D24.16)
 300  format(/,'FINAL ESTIMATION OF THE LAGRANGE MULTIPLIERS: ',
     +       //,2X,'INDEX',11X,'LAMBDA(INDEX)')

      end

C     ******************************************************************
C     ******************************************************************

      subroutine vevalf(n,x,f,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,n
      double precision f

C     ARRAY ARGUMENTS
      double precision x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      character * 6 hptype
      character * 2 innslvr
      logical ccoded,fccoded,fcoded,gcoded,gjaccoded,innercall,jaccoded,
     +        hcoded,hccoded,hlcoded,hlpcoded,firstde,truehl,ignoref,
     +        skipacc,sclsys,useustp,safemode

C     COMMON BLOCKS
      common /algparam/ fcoded,gcoded,hcoded,ccoded,jaccoded,hccoded,
     +                  hlcoded,hlpcoded,fccoded,gjaccoded,firstde,
     +                  truehl,ignoref,skipacc,sclsys,innercall,useustp,
     +                  innslvr,hptype,safemode
      save   /algparam/
C     COMMON SCALARS
      integer efcnt,efccnt,egcnt,egjccnt,ehcnt,ehlcnt,ehlpcnt,fcnt

C     COMMON ARRAYS
      integer eccnt(mmax),ehccnt(mmax),ejccnt(mmax)

C     COMMON BLOCKS
      common /counters/ eccnt,ehccnt,ejccnt,efcnt,efccnt,egcnt,egjccnt,
     +                  ehcnt,ehlcnt,ehlpcnt,fcnt
      save   /counters/
C     COMMON SCALARS
      logical iprintctl(7)
      integer iprintinn,iprintout,mprint,nprint

C     COMMON BLOCKS
      common /outdat/ iprintctl,iprintinn,iprintout,nprint,mprint
      save   /outdat/


C     LOCAL SCALARS
      integer ercode,flag

C     EXTERNAL FUNCTIONS
      logical IsANumber
      external IsANumber

C     EXTERNAL SUBROUTINES
      external evalf

      call evalf(n,x,f,flag)

      efcnt = efcnt + 1
      fcnt  = fcnt  + 1

      if ( flag .ne. 0 ) then
          if ( iprintctl(3) ) then
              write(* ,100)
              write(10,100)
          end if

          if ( safemode ) then
              inform = - 90
              call reperr(inform)
              return
          end if
      end if

      if ( .not. IsANumber(f) ) then
          if ( iprintctl(3) ) then
              write(* ,200)
              write(* ,300) f
              write(10,200)
              write(10,300) f
          end if

          if ( safemode ) then
              inform = - 90
              call reperr(inform)
              return
          end if
      end if

C     NON-EXECUTABLE STATEMENTS

 100  format(/,1X,'VEVALF WARNING: A non-null flag was returned.',/)

 200  format(/,1X,'VEVALF WARNING: The objective function value ',
     +            'computed by the user-supplied subroutine EVALF is ',
     +            '+Inf, -Inf or NaN.')

 300  format(/,1X,'Value: ',1P,D24.16)

      end

C     ******************************************************************
C     ******************************************************************

      subroutine vevalg(n,x,g,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,n

C     ARRAY ARGUMENTS
      double precision g(n),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      character * 6 hptype
      character * 2 innslvr
      logical ccoded,fccoded,fcoded,gcoded,gjaccoded,innercall,jaccoded,
     +        hcoded,hccoded,hlcoded,hlpcoded,firstde,truehl,ignoref,
     +        skipacc,sclsys,useustp,safemode

C     COMMON BLOCKS
      common /algparam/ fcoded,gcoded,hcoded,ccoded,jaccoded,hccoded,
     +                  hlcoded,hlpcoded,fccoded,gjaccoded,firstde,
     +                  truehl,ignoref,skipacc,sclsys,innercall,useustp,
     +                  innslvr,hptype,safemode
      save   /algparam/
C     COMMON SCALARS
      integer efcnt,efccnt,egcnt,egjccnt,ehcnt,ehlcnt,ehlpcnt,fcnt

C     COMMON ARRAYS
      integer eccnt(mmax),ehccnt(mmax),ejccnt(mmax)

C     COMMON BLOCKS
      common /counters/ eccnt,ehccnt,ejccnt,efcnt,efccnt,egcnt,egjccnt,
     +                  ehcnt,ehlcnt,ehlpcnt,fcnt
      save   /counters/
C     COMMON SCALARS
      logical iprintctl(7)
      integer iprintinn,iprintout,mprint,nprint

C     COMMON BLOCKS
      common /outdat/ iprintctl,iprintinn,iprintout,nprint,mprint
      save   /outdat/


C     LOCAL SCALARS
      integer flag,i

C     EXTERNAL FUNCTIONS
      logical IsANumber
      external IsANumber

C     EXTERNAL SUBROUTINES
      external evalg,ivevalg

      if ( gcoded ) then
          call evalg(n,x,g,flag)

          egcnt = egcnt + 1

          if ( flag .ne. 0 ) then
              if ( iprintctl(3) ) then
                  write(* ,100)
                  write(10,100)
              end if

              if ( safemode ) then
                  inform = - 92
                  call reperr(inform)
                  return
              end if
          end if

          do i = 1,n
              if ( .not. IsANumber(g(i)) ) then
                  if ( iprintctl(3) ) then
                      write(* ,200)
                      write(* ,300) n,i,g(i)
                      write(10,200)
                      write(10,300) n,i,g(i)
                  end if

                  if ( safemode ) then
                      inform = - 92
                      call reperr(inform)
                      return
                  end if
              end if
          end do

      else
          call ivevalg(n,x,g,inform)
          if ( inform .lt. 0 ) return
      end if

C     NON-EXECUTABLE STATEMENTS

 100  format(/,1X,'VEVALG WARNING: A non-null flag was returned.',/)

 200  format(/,1X,'VEVALG WARNING: There is an element whose value is ',
     +            '+Inf, -Inf or NaN in the gradient of the objective ',
     +            'function computed by the user-supplied subroutine ',
     +            'EVALG.')

 300  format(/,1X,'Dimension of the space: ',I16,
     +       /,1X,'Position              : ',I16,
     +       /,1X,'Value                 : ',1P,D24.16)

      end

C     ******************************************************************
C     ******************************************************************

      subroutine ivevalg(n,x,g,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,n

C     ARRAY ARGUMENTS
      double precision g(n),x(n)

C     COMMON SCALARS
      double precision bignum,macheps,macheps12,macheps13,macheps23

C     COMMON BLOCKS
      common /machcon/ bignum,macheps,macheps12,macheps13,macheps23
      save   /machcon/

C     LOCAL SCALARS
      integer j
      double precision fminus,fplus,step,tmp

C     INTRINSIC FUNCTIONS
      intrinsic abs,max

C     EXTERNAL SUBROUTINES
      external setp,vevalf

      do j = 1,n
          tmp  = x(j)

          step = macheps13 * max( 1.0d0, abs( tmp ) )

          x(j) = tmp + step
          call setp(n,x)
          call vevalf(n,x,fplus,inform)
          if ( inform .lt. 0 ) return

          x(j) = tmp - step
          call setp(n,x)
          call vevalf(n,x,fminus,inform)
          if ( inform .lt. 0 ) return

          g(j) = ( fplus - fminus ) / ( 2.0d0 * step )

          x(j) = tmp
      end do

      end

C     ******************************************************************
C     ******************************************************************

      subroutine vevalh(n,x,hlin,hcol,hval,hnnz,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,n,hnnz

C     ARRAY ARGUMENTS
      integer hcol(*),hlin(*)
      double precision hval(*),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      character * 6 hptype
      character * 2 innslvr
      logical ccoded,fccoded,fcoded,gcoded,gjaccoded,innercall,jaccoded,
     +        hcoded,hccoded,hlcoded,hlpcoded,firstde,truehl,ignoref,
     +        skipacc,sclsys,useustp,safemode

C     COMMON BLOCKS
      common /algparam/ fcoded,gcoded,hcoded,ccoded,jaccoded,hccoded,
     +                  hlcoded,hlpcoded,fccoded,gjaccoded,firstde,
     +                  truehl,ignoref,skipacc,sclsys,innercall,useustp,
     +                  innslvr,hptype,safemode
      save   /algparam/
C     COMMON SCALARS
      integer efcnt,efccnt,egcnt,egjccnt,ehcnt,ehlcnt,ehlpcnt,fcnt

C     COMMON ARRAYS
      integer eccnt(mmax),ehccnt(mmax),ejccnt(mmax)

C     COMMON BLOCKS
      common /counters/ eccnt,ehccnt,ejccnt,efcnt,efccnt,egcnt,egjccnt,
     +                  ehcnt,ehlcnt,ehlpcnt,fcnt
      save   /counters/
C     COMMON SCALARS
      logical iprintctl(7)
      integer iprintinn,iprintout,mprint,nprint

C     COMMON BLOCKS
      common /outdat/ iprintctl,iprintinn,iprintout,nprint,mprint
      save   /outdat/


C     LOCAL SCALARS
      integer flag,i

C     EXTERNAL FUNCTIONS
      logical IsANumber
      external IsANumber

C     EXTERNAL SUBROUTINES
      external evalh,reperr

      call evalh(n,x,hlin,hcol,hval,hnnz,flag)

      ehcnt = ehcnt + 1

      if ( flag .ne. 0 ) then
          if ( iprintctl(3) ) then
              write(* ,100)
              write(10,100)
          end if

          if ( safemode ) then
              inform = - 94
              call reperr(inform)
              return
          end if
      end if

      do i = 1,hnnz
          if ( hlin(i) .lt. 1 .or. hlin(i) .gt. n .or.
     +         hcol(i) .lt. 1 .or. hcol(i) .gt. n .or.
     +         hcol(i) .gt. hlin(i) ) then

              if ( iprintctl(3) ) then
                  write(* ,200)
                  write(* ,400) n,i,hlin(i),hcol(i),hval(i)
                  write(10,200)
                  write(10,400) n,i,hlin(i),hcol(i),hval(i)
              end if

              hlin(i) = 1
              hcol(i) = 1
              hval(i) = 0.0d0
          end if

          if ( .not. IsANumber(hval(i)) ) then
              if ( iprintctl(3) ) then
                  write(* ,300)
                  write(* ,400) n,i,hlin(i),hcol(i),hval(i)
                  write(10,300)
                  write(10,400) n,i,hlin(i),hcol(i),hval(i)
              end if

              if ( safemode ) then
                  inform = - 94
                  call reperr(inform)
                  return
              end if
          end if
      end do

C     NON-EXECUTABLE STATEMENTS

 100  format(/,1X,'VEVALH WARNING: A non-null flag was returned.',/)

 200  format(/,1X,'VEVALH WARNING: There is an element out of range, ',
     +            'or in the upper triangle, of the Hessian of the ',
     +            'objetive function computed by the user-supplied ',
     +            'subroutine EVALH. It will be ignored.')

 300  format(/,1X,'VEVALH WARNING: There is an element whose value is ',
     +            '+Inf, -Inf or NaN in the Hessian of the objetive ',
     +            'function computed by the user-supplied subroutine ',
     +            'EVALH.')

 400  format(/,1X,'Dimension: ',I16,
     +       /,1X,'Position : ',I16,
     +       /,1X,'Row      : ',I16,
     +       /,1X,'Column   : ',I16,
     +       /,1X,'Value    : ',1P,D24.16)

      end

C     ******************************************************************
C     ******************************************************************

      subroutine vevalc(n,x,ind,c,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer ind,inform,n
      double precision c

C     ARRAY ARGUMENTS
      double precision x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      character * 6 hptype
      character * 2 innslvr
      logical ccoded,fccoded,fcoded,gcoded,gjaccoded,innercall,jaccoded,
     +        hcoded,hccoded,hlcoded,hlpcoded,firstde,truehl,ignoref,
     +        skipacc,sclsys,useustp,safemode

C     COMMON BLOCKS
      common /algparam/ fcoded,gcoded,hcoded,ccoded,jaccoded,hccoded,
     +                  hlcoded,hlpcoded,fccoded,gjaccoded,firstde,
     +                  truehl,ignoref,skipacc,sclsys,innercall,useustp,
     +                  innslvr,hptype,safemode
      save   /algparam/
C     COMMON SCALARS
      integer efcnt,efccnt,egcnt,egjccnt,ehcnt,ehlcnt,ehlpcnt,fcnt

C     COMMON ARRAYS
      integer eccnt(mmax),ehccnt(mmax),ejccnt(mmax)

C     COMMON BLOCKS
      common /counters/ eccnt,ehccnt,ejccnt,efcnt,efccnt,egcnt,egjccnt,
     +                  ehcnt,ehlcnt,ehlpcnt,fcnt
      save   /counters/
C     COMMON SCALARS
      logical iprintctl(7)
      integer iprintinn,iprintout,mprint,nprint

C     COMMON BLOCKS
      common /outdat/ iprintctl,iprintinn,iprintout,nprint,mprint
      save   /outdat/


C     LOCAL SCALARS
      integer flag

C     EXTERNAL FUNCTIONS
      logical IsANumber
      external IsANumber

C     EXTERNAL SUBROUTINES
      external evalc,reperr

      call evalc(n,x,ind,c,flag)

      eccnt(ind) = eccnt(ind) + 1

      if ( flag .ne. 0 ) then
          if ( iprintctl(3) ) then
              write(* ,100)
              write(10,100)
          end if

          if ( safemode ) then
              inform = - 91
              call reperr(inform)
              return
          end if
      end if

      if ( .not. IsANumber(c) ) then
          if ( iprintctl(3) ) then
              write(* ,200) ind
              write(* ,300) c
              write(10,200) ind
              write(10,300) c
          end if

          if ( safemode ) then
              inform = - 91
              call reperr(inform)
              return
          end if
      end if

C     NON-EXECUTABLE STATEMENTS

 100  format(/,1X,'VEVALC WARNING: A non-null flag was returned.',/)

 200  format(/,1X,'VEVALC WARNING: The value of constraint ',I16,' ',
     +            'computed by the user-supplied subroutine EVALC is ',
     +            '+Inf, -Inf or NaN.')

 300  format(/,1X,'Value: ',1P,D24.16)

      end

C     ******************************************************************
C     ******************************************************************

      subroutine vevaljac(n,x,ind,jcvar,jcval,jcnnz,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,ind,n,jcnnz

C     ARRAY ARGUMENTS
      integer jcvar(n)
      double precision x(n),jcval(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      character * 6 hptype
      character * 2 innslvr
      logical ccoded,fccoded,fcoded,gcoded,gjaccoded,innercall,jaccoded,
     +        hcoded,hccoded,hlcoded,hlpcoded,firstde,truehl,ignoref,
     +        skipacc,sclsys,useustp,safemode

C     COMMON BLOCKS
      common /algparam/ fcoded,gcoded,hcoded,ccoded,jaccoded,hccoded,
     +                  hlcoded,hlpcoded,fccoded,gjaccoded,firstde,
     +                  truehl,ignoref,skipacc,sclsys,innercall,useustp,
     +                  innslvr,hptype,safemode
      save   /algparam/
C     COMMON SCALARS
      integer efcnt,efccnt,egcnt,egjccnt,ehcnt,ehlcnt,ehlpcnt,fcnt

C     COMMON ARRAYS
      integer eccnt(mmax),ehccnt(mmax),ejccnt(mmax)

C     COMMON BLOCKS
      common /counters/ eccnt,ehccnt,ejccnt,efcnt,efccnt,egcnt,egjccnt,
     +                  ehcnt,ehlcnt,ehlpcnt,fcnt
      save   /counters/
C     COMMON SCALARS
      logical iprintctl(7)
      integer iprintinn,iprintout,mprint,nprint

C     COMMON BLOCKS
      common /outdat/ iprintctl,iprintinn,iprintout,nprint,mprint
      save   /outdat/


C     LOCAL SCALARS
      integer flag,i

C     EXTERNAL FUNCTIONS
      logical IsANumber
      external IsANumber

C     EXTERNAL SUBROUTINES
      external evaljac,ivevaljac,reperr

      if ( jaccoded ) then
          call evaljac(n,x,ind,jcvar,jcval,jcnnz,flag)

          ejccnt(ind) = ejccnt(ind) + 1

          if ( flag .ne. 0 ) then
              if ( iprintctl(3) ) then
                  write(* ,100)
                  write(10,100)
              end if

              if ( safemode ) then
                  inform = - 93
                  call reperr(inform)
                  return
              end if
          end if

          do i = 1,jcnnz
              if ( jcvar(i) .lt. 1 .or. jcvar(i) .gt. n ) then

                  if ( iprintctl(3) ) then
                      write(* ,200) ind
                      write(* ,400) n,i,jcvar(i),jcval(i)
                      write(10,200) ind
                      write(10,400) n,i,jcvar(i),jcval(i)
                  end if

                  jcvar(i) = 1
                  jcval(i) = 0.0d0
              end if

              if ( .not. IsANumber(jcval(i)) ) then
                  if ( iprintctl(3) ) then
                      write(* ,300) ind
                      write(* ,400) n,i,jcvar(i),jcval(i)
                      write(10,300) ind
                      write(10,400) n,i,jcvar(i),jcval(i)
                  end if

                  if ( safemode ) then
                      inform = - 93
                      call reperr(inform)
                      return
                  end if
              end if
          end do

      else
          call ivevaljac(n,x,ind,jcvar,jcval,jcnnz,inform)
          if ( inform .lt. 0 ) return
      end if

C     NON-EXECUTABLE STATEMENTS

 100  format(/,1X,'VEVALJAC WARNING: A non-null flag was returned.',/)

 200  format(/,1X,'VEVALJAC WARNING: There is an element out of ',
     +            'range in the gradient of constraint ',I16,' ',
     +            'computed by the user-supplied subroutine EVALJAC. ',
     +            'It will be ignored.')

 300  format(/,1X,'VEVALJAC WARNING: There is an element whose value ',
     +            'is +Inf, -Inf or NaN in the gradient of constraint ',
     +            I16,'computed by the user-supplied subroutine ',
     +            'EVALJAC.')

 400  format(/,1X,'Dimension: ',I16,
     +       /,1X,'Position : ',I16,
     +       /,1X,'Variable : ',I16,
     +       /,1X,'Value    : ',1P,D24.16)

      end

C     ******************************************************************
C     ******************************************************************

      subroutine ivevaljac(n,x,ind,jcvar,jcval,jcnnz,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer ind,inform,n,jcnnz

C     ARRAY ARGUMENTS
      integer jcvar(n)
      double precision jcval(n),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      double precision bignum,macheps,macheps12,macheps13,macheps23

C     COMMON BLOCKS
      common /machcon/ bignum,macheps,macheps12,macheps13,macheps23
      save   /machcon/

C     LOCAL SCALARS
      integer j
      double precision cminus,cplus,step,tmp

C     INTRINSEC FUNCTIONS
      intrinsic abs,max

C     EXTERNAL SUBROUTINES
      external setp,vevalc

      jcnnz = 0

      do j = 1,n
          tmp  = x(j)

          step = macheps13 * max( 1.0d0, abs( tmp ) )

          x(j) = tmp + step
          call setp(n,x)
          call vevalc(n,x,ind,cplus,inform)
          if ( inform .lt. 0 ) return

          x(j) = tmp - step
          call setp(n,x)
          call vevalc(n,x,ind,cminus,inform)
          if ( inform .lt. 0 ) return

          jcvar(jcnnz + 1) = j
          jcval(jcnnz + 1) = ( cplus - cminus ) / ( 2.0d0 * step )

          if ( abs( jcval(jcnnz + 1) ) .gt. 0.0d0 ) then
              jcnnz = jcnnz + 1
          end if

          x(j) = tmp
      end do

      end

C     ******************************************************************
C     ******************************************************************

      subroutine vevalhc(n,x,ind,hlin,hcol,hval,hnnz,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,ind,n,hnnz

C     ARRAY ARGUMENTS
      integer hcol(*),hlin(*)
      double precision hval(*),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      character * 6 hptype
      character * 2 innslvr
      logical ccoded,fccoded,fcoded,gcoded,gjaccoded,innercall,jaccoded,
     +        hcoded,hccoded,hlcoded,hlpcoded,firstde,truehl,ignoref,
     +        skipacc,sclsys,useustp,safemode

C     COMMON BLOCKS
      common /algparam/ fcoded,gcoded,hcoded,ccoded,jaccoded,hccoded,
     +                  hlcoded,hlpcoded,fccoded,gjaccoded,firstde,
     +                  truehl,ignoref,skipacc,sclsys,innercall,useustp,
     +                  innslvr,hptype,safemode
      save   /algparam/
C     COMMON SCALARS
      integer efcnt,efccnt,egcnt,egjccnt,ehcnt,ehlcnt,ehlpcnt,fcnt

C     COMMON ARRAYS
      integer eccnt(mmax),ehccnt(mmax),ejccnt(mmax)

C     COMMON BLOCKS
      common /counters/ eccnt,ehccnt,ejccnt,efcnt,efccnt,egcnt,egjccnt,
     +                  ehcnt,ehlcnt,ehlpcnt,fcnt
      save   /counters/
C     COMMON SCALARS
      logical iprintctl(7)
      integer iprintinn,iprintout,mprint,nprint

C     COMMON BLOCKS
      common /outdat/ iprintctl,iprintinn,iprintout,nprint,mprint
      save   /outdat/


C     LOCAL SCALARS
      integer flag,i

C     EXTERNAL FUNCTIONS
      logical IsANumber
      external IsANumber

C     EXTERNAL SUBROUTINES
      external evalhc,reperr

      call evalhc(n,x,ind,hlin,hcol,hval,hnnz,flag)

      ehccnt(ind) = ehccnt(ind) + 1

      if ( flag .ne. 0 ) then
          if ( iprintctl(3) ) then
              write(* ,100)
              write(10,100)
          end if

          if ( safemode ) then
              inform = - 95
              call reperr(inform)
              return
          end if
      end if

      do i = 1,hnnz
          if ( hlin(i) .lt. 1 .or. hlin(i) .gt. n .or.
     +         hcol(i) .lt. 1 .or. hcol(i) .gt. n .or.
     +         hcol(i) .gt. hlin(i) ) then

              if ( iprintctl(3) ) then
                  write(* ,200) ind
                  write(* ,400) n,i,hlin(i),hcol(i),hval(i)
                  write(10,200) ind
                  write(10,400) n,i,hlin(i),hcol(i),hval(i)
              end if

              hlin(i) = 1
              hcol(i) = 1
              hval(i) = 0.0d0
          end if

          if ( .not. IsANumber(hval(i)) ) then
              if ( iprintctl(3) ) then
                  write(* ,300) ind
                  write(* ,400) n,i,hlin(i),hcol(i),hval(i)
                  write(10,300) ind
                  write(10,400) n,i,hlin(i),hcol(i),hval(i)
              end if

              if ( safemode ) then
                  inform = - 95
                  call reperr(inform)
                  return
              end if
          end if
      end do

C     NON-EXECUTABLE STATEMENTS

 100  format(/,1X,'VEVALHC WARNING: A non-null flag was returned.',/)

 200  format(/,1X,'VEVALHC WARNING: There is an element out of range ',
     +            'or in the upper triangle of the Hessian of ',
     +            'constraint ',I16,' computed by the user-supplied ',
     +            'subroutine EVALHC. It will be ignored.')

 300  format(/,1X,'VEVALHC WARNING: There is an element whose value ',
     +            'is +Inf, -Inf or NaN in the Hessian of constraint ',
     +            I16,' computed by the user-supplied subroutine ',
     +            'EVALHC.')

 400  format(/,1X,'Dimension: ',I16,
     +       /,1X,'Position : ',I16,
     +       /,1X,'Row      : ',I16,
     +       /,1X,'Column   : ',I16,
     +       /,1X,'Value    : ',1P,D24.16)

      end

C     ******************************************************************
C     ******************************************************************

      subroutine vevalhl(n,x,m,lambda,sf,sc,hlin,hcol,hval,hnnz,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer hnnz,inform,m,n
      double precision sf

C     ARRAY ARGUMENTS
      integer hlin(*),hcol(*)
      double precision hval(*),lambda(m),sc(m),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      character * 6 hptype
      character * 2 innslvr
      logical ccoded,fccoded,fcoded,gcoded,gjaccoded,innercall,jaccoded,
     +        hcoded,hccoded,hlcoded,hlpcoded,firstde,truehl,ignoref,
     +        skipacc,sclsys,useustp,safemode

C     COMMON BLOCKS
      common /algparam/ fcoded,gcoded,hcoded,ccoded,jaccoded,hccoded,
     +                  hlcoded,hlpcoded,fccoded,gjaccoded,firstde,
     +                  truehl,ignoref,skipacc,sclsys,innercall,useustp,
     +                  innslvr,hptype,safemode
      save   /algparam/
C     COMMON SCALARS
      integer efcnt,efccnt,egcnt,egjccnt,ehcnt,ehlcnt,ehlpcnt,fcnt

C     COMMON ARRAYS
      integer eccnt(mmax),ehccnt(mmax),ejccnt(mmax)

C     COMMON BLOCKS
      common /counters/ eccnt,ehccnt,ejccnt,efcnt,efccnt,egcnt,egjccnt,
     +                  ehcnt,ehlcnt,ehlpcnt,fcnt
      save   /counters/
C     COMMON SCALARS
      logical iprintctl(7)
      integer iprintinn,iprintout,mprint,nprint

C     COMMON BLOCKS
      common /outdat/ iprintctl,iprintinn,iprintout,nprint,mprint
      save   /outdat/


C     LOCAL SCALARS
      integer flag,i

C     EXTERNAL FUNCTIONS
      logical IsANumber
      external IsANumber

C     EXTERNAL SUBROUTINES
      external evalhl,ivevalhl,reperr

      if ( hlcoded ) then

          call evalhl(n,x,m,lambda,sf,sc,hlin,hcol,hval,hnnz,flag)

          ehlcnt = ehlcnt + 1

          if ( flag .ne. 0 ) then
              if ( iprintctl(3) ) then
                  write(* ,100)
                  write(10,100)
              end if

              if ( safemode ) then
                  inform = - 96
                  call reperr(inform)
                  return
              end if
          end if

          do i = 1,hnnz
              if ( hlin(i) .lt. 1 .or. hlin(i) .gt. n .or.
     +             hcol(i) .lt. 1 .or. hcol(i) .gt. n .or.
     +             hcol(i) .gt. hlin(i) ) then

                  if ( iprintctl(3) ) then
                      write(* ,200)
                      write(* ,400) n,i,hlin(i),hcol(i),hval(i)
                      write(10,200)
                      write(10,400) n,i,hlin(i),hcol(i),hval(i)
                  end if

                  hlin(i) = 1
                  hcol(i) = 1
                  hval(i) = 0.0d0
              end if

              if ( .not. IsANumber(hval(i)) ) then
                  if ( iprintctl(3) ) then
                      write(* ,300)
                      write(* ,400) n,i,hlin(i),hcol(i),hval(i)
                      write(10,300)
                      write(10,400) n,i,hlin(i),hcol(i),hval(i)
                  end if

                  if ( safemode ) then
                      inform = - 96
                      call reperr(inform)
                      return
                  end if
              end if
          end do

      else if ( hcoded .and. ( hccoded .or. m .eq. 0 ) ) then
         call ivevalhl(n,x,m,lambda,sf,sc,hlin,hcol,hval,hnnz,inform)
         if ( inform .lt. 0 ) return
      end if

C     NON-EXECUTABLE STATEMENTS

 100  format(/,1X,'VEVALHL WARNING: A non-null flag was returned.',/)

 200  format(/,1X,'VEVALHL WARNING: There is an element out of range, ',
     +            'or in the upper triangle, of the',/,1X,'Hessian of ',
     +            'the Lagrangian computed by the user-supplied ',
     +            'subroutine EVALHL. It',/,1X,'will be ignored.')

 300  format(/,1X,'VEVALHL WARNING: There is an element whose value ',
     +            'is +Inf, -Inf or NaN in the',/,1X,'Hessian of the ',
     +            'Lagrangian computed by the user-supplied ',
     +            'subroutine EVALHL.')

 400  format(/,1X,'Dimension: ',I16,
     +       /,1X,'Position : ',I16,
     +       /,1X,'Row      : ',I16,
     +       /,1X,'Column   : ',I16,
     +       /,1X,'Value    : ',1P,D24.16)

      end

C     ******************************************************************
C     ******************************************************************

      subroutine ivevalhl(n,x,m,lambda,sf,sc,hlin,hcol,hval,hnnz,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer hnnz,inform,m,n
      double precision sf

C     ARRAY ARGUMENTS
      integer hlin(*),hcol(*)
      double precision hval(*),lambda(m),sc(m),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      character * 6 hptype
      character * 2 innslvr
      logical ccoded,fccoded,fcoded,gcoded,gjaccoded,innercall,jaccoded,
     +        hcoded,hccoded,hlcoded,hlpcoded,firstde,truehl,ignoref,
     +        skipacc,sclsys,useustp,safemode

C     COMMON BLOCKS
      common /algparam/ fcoded,gcoded,hcoded,ccoded,jaccoded,hccoded,
     +                  hlcoded,hlpcoded,fccoded,gjaccoded,firstde,
     +                  truehl,ignoref,skipacc,sclsys,innercall,useustp,
     +                  innslvr,hptype,safemode
      save   /algparam/

C     LOCAL SCALARS
      integer col,con,hnnztmp,i,ind,itmp,j,lin,nextj,rnnz
      double precision val

C     LOCAL ARRAYS
      integer hcon(hnnzmax),pos(nmax),rind(nmax),stlin(nmax)
      double precision rval(nmax)

C     EXTERNAL SUBROUTINES
      external vevalh,vevalhc

C     ==================================================================
C     COMPUTE HESSIANS
C     ==================================================================

C     COMPUTE HESSIAN OF THE OBJECTIVE FUNCTION

      if ( ignoref ) then
          hnnz = 0

      else
C         Compute Hessian of the objective function
          call vevalh(n,x,hlin,hcol,hval,hnnz,inform)
          if ( inform .lt. 0 ) return

C         For each element of the Hessian of the objective function,
C         set constraint index as zero
          do i = 1,hnnz
              hval(i) = hval(i) * sf
              hcon(i) = 0
          end do
      end if

      if ( m .eq. 0 ) return

C     COMPUTE HESSIANS OF THE CONSTRAINTS

      ind = 0

      do j = 1,m
C         Compute Hessian of constraint j
          call vevalhc(n,x,j,hlin(hnnz+ind+1),hcol(hnnz+ind+1),
     +    hval(hnnz+ind+1),hnnztmp,inform)
          if ( inform .lt. 0 ) return

C         For each element of the Hessian, set constraint as j
          do i = hnnz + ind + 1,hnnz + ind + hnnztmp
              hval(i) = hval(i) * sc(j)
              hcon(i) = j
          end do

          ind = ind + hnnztmp
      end do

      if ( ind .eq. 0 ) return

      hnnz = hnnz + ind

C     ==================================================================
C     SET ROW LINKED LISTS
C     ==================================================================

C     Initialize pointers to the first element of each row
      do i = 1,n
         stlin(i) = 0
      end do

C     Set row linked lists
      do i = 1,hnnz
         lin        = hlin(i)
         itmp       = stlin(lin)
         stlin(lin) = i
         hlin(i)    = itmp
      end do

C     ==================================================================
C     BUILD HESSIAN OF THE LAGRANGIAN ROW BY ROW
C     ==================================================================

C     Initialize array pos
      do i = 1,n
          pos(i) = 0
      end do

      do i = 1,n
C         Initialize the i-th row of the Hessian of the Lagrangian
          rnnz = 0

C         Process the i-th row of all the Hessians
          j = stlin(i)

 10       if ( j .ne. 0 ) then

C             Process element (i,hcol(j)) of the Hessian of constraint
C             hcon(j) (Hessian of the objective function if hcon(j)=0)

              col = hcol(j)
              con = hcon(j)
              if ( con .eq. 0 ) then
                  val = hval(j)
              else
                  val = hval(j) * lambda(con)
              end if

              if ( pos(col) .ne. 0 ) then
                  rval(pos(col)) = rval(pos(col)) + val

              else
                  rnnz           = rnnz + 1
                  pos(col)       = rnnz
                  rind(pos(col)) = col
                  rval(pos(col)) = val
              end if

C             Get next element in the i-th row linked list
              j = hlin(j)
              go to 10
          end if

C         Clean array pos
          do j = 1,rnnz
              pos(rind(j)) = 0
          end do

C         Set i-th row of hl (over the i-th rows of the Hessians)
C         and mark remaining elements to be deleted
          j = stlin(i)

 20       if ( j .ne. 0 ) then
              nextj = hlin(j)

              if ( rnnz .ne. 0 ) then
                  hlin(j) = i
                  hcol(j) = rind(rnnz)
                  hval(j) = rval(rnnz)
                  rnnz    = rnnz - 1
              else
                  hlin(j) = 0
              end if

              j = nextj
              go to 20
          end if

      end do

C     Eliminate remaining elements (marked with hlin(j)=0)
      j = 1

 30   if ( j .le. hnnz ) then
          if ( hlin(j) .eq. 0 ) then
              if ( j .ne. hnnz ) then
                  hlin(j) = hlin(hnnz)
                  hcol(j) = hcol(hnnz)
                  hval(j) = hval(hnnz)
              end if
              hnnz = hnnz - 1
          else
              j = j + 1
          end if

          go to 30
      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine vevalhlp(n,x,m,lambda,sf,sc,p,hp,gothl,inform)

      implicit none

C     SCALAR ARGUMENTS
      logical gothl
      integer inform,m,n
      double precision sf

C     ARRAY ARGUMENTS
      double precision hp(n),lambda(m),p(n),sc(m),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      character * 6 hptype
      character * 2 innslvr
      logical ccoded,fccoded,fcoded,gcoded,gjaccoded,innercall,jaccoded,
     +        hcoded,hccoded,hlcoded,hlpcoded,firstde,truehl,ignoref,
     +        skipacc,sclsys,useustp,safemode

C     COMMON BLOCKS
      common /algparam/ fcoded,gcoded,hcoded,ccoded,jaccoded,hccoded,
     +                  hlcoded,hlpcoded,fccoded,gjaccoded,firstde,
     +                  truehl,ignoref,skipacc,sclsys,innercall,useustp,
     +                  innslvr,hptype,safemode
      save   /algparam/
C     COMMON SCALARS
      integer efcnt,efccnt,egcnt,egjccnt,ehcnt,ehlcnt,ehlpcnt,fcnt

C     COMMON ARRAYS
      integer eccnt(mmax),ehccnt(mmax),ejccnt(mmax)

C     COMMON BLOCKS
      common /counters/ eccnt,ehccnt,ejccnt,efcnt,efccnt,egcnt,egjccnt,
     +                  ehcnt,ehlcnt,ehlpcnt,fcnt
      save   /counters/
C     COMMON SCALARS
      logical iprintctl(7)
      integer iprintinn,iprintout,mprint,nprint

C     COMMON BLOCKS
      common /outdat/ iprintctl,iprintinn,iprintout,nprint,mprint
      save   /outdat/


C     LOCAL SCALARS
      integer flag,i

C     EXTERNAL FUNCTIONS
      logical IsANumber
      external IsANumber

C     EXTERNAL SUBROUTINES
      external evalhlp,ivevalhlp,reperr

      if ( hlpcoded ) then
          call evalhlp(n,x,m,lambda,sf,sc,p,hp,gothl,flag)

          ehlpcnt = ehlpcnt + 1

          if ( flag .ne. 0 ) then
              if ( iprintctl(3) ) then
                  write(* ,100)
                  write(10,100)
              end if

              if ( safemode ) then
                  inform = - 97
                  call reperr(inform)
                  return
              end if
          end if

          do i = 1,n
              if ( .not. IsANumber(hp(i)) ) then
                  if ( iprintctl(3) ) then
                      write(* ,200)
                      write(* ,300) n,i,hp(i)
                      write(10,200)
                      write(10,300) n,i,hp(i)
                  end if

                  if ( safemode ) then
                      inform = - 97
                      call reperr(inform)
                      return
                  end if
              end if
          end do

      else if ( truehl ) then
          call ivevalhlp(n,x,m,lambda,sf,sc,p,hp,gothl,inform)
          if ( inform .lt. 0 ) return
      end if

C     NON-EXECUTABLE STATEMENTS

 100  format(/,1X,'VEVALHLP WARNING: A non-null flag was returned.',/)

 200  format(/,1X,'VEVALHLP WARNING: There is an element in the ',
     +            'product of the Hessian of the Lagrangian by a ',
     +            'computed by the user-supplied subroutine EVALHLP ',
     +            'whose value is +Inf, -Inf or NaN.')

 300  format(/,1X,'Dimension of the space: ',I16,
     +       /,1X,'Position              : ',I16,
     +       /,1X,'Value                 : ',1P,D24.16)

      end

C     ******************************************************************
C     ******************************************************************

      subroutine ivevalhlp(n,x,m,lambda,sf,sc,p,hp,gothl,inform)

      implicit none

C     SCALAR ARGUMENTS
      logical gothl
      integer inform,m,n
      double precision sf

C     ARRAY ARGUMENTS
      double precision hp(n),lambda(m),p(n),sc(m),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      integer hnnz

C     COMMON ARRAYS
      integer hcol(hnnzmax),hlin(hnnzmax)
      double precision hval(hnnzmax)

C     COMMON BLOCKS
      common /hdata/ hval,hlin,hcol,hnnz
      save   /hdata/

C     LOCAL SCALARS
      integer col,i,lin
      double precision val

C     EXTERNAL SUBROUTINES
      external vevalhl

      if ( .not. gothl ) then
          gothl = .true.

          call vevalhl(n,x,m,lambda,sf,sc,hlin,hcol,hval,hnnz,inform)
          if ( inform .lt. 0 ) return
      end if

      do i = 1,n
          hp(i) = 0.0d0
      end do

      do i = 1,hnnz
          lin = hlin(i)
          col = hcol(i)
          val = hval(i)

          hp(lin) = hp(lin) + p(col) * val

          if ( lin .ne. col ) then
              hp(col) = hp(col) + p(lin) * val
          end if
      end do

      end

C     ******************************************************************
C     ******************************************************************

      subroutine vevalfc(n,x,f,m,c,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,m,n
      double precision f

C     ARRAY ARGUMENTS
      double precision c(m),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      character * 6 hptype
      character * 2 innslvr
      logical ccoded,fccoded,fcoded,gcoded,gjaccoded,innercall,jaccoded,
     +        hcoded,hccoded,hlcoded,hlpcoded,firstde,truehl,ignoref,
     +        skipacc,sclsys,useustp,safemode

C     COMMON BLOCKS
      common /algparam/ fcoded,gcoded,hcoded,ccoded,jaccoded,hccoded,
     +                  hlcoded,hlpcoded,fccoded,gjaccoded,firstde,
     +                  truehl,ignoref,skipacc,sclsys,innercall,useustp,
     +                  innslvr,hptype,safemode
      save   /algparam/
C     COMMON SCALARS
      integer efcnt,efccnt,egcnt,egjccnt,ehcnt,ehlcnt,ehlpcnt,fcnt

C     COMMON ARRAYS
      integer eccnt(mmax),ehccnt(mmax),ejccnt(mmax)

C     COMMON BLOCKS
      common /counters/ eccnt,ehccnt,ejccnt,efcnt,efccnt,egcnt,egjccnt,
     +                  ehcnt,ehlcnt,ehlpcnt,fcnt
      save   /counters/
C     COMMON SCALARS
      logical iprintctl(7)
      integer iprintinn,iprintout,mprint,nprint

C     COMMON BLOCKS
      common /outdat/ iprintctl,iprintinn,iprintout,nprint,mprint
      save   /outdat/


C     LOCAL SCALARS
      integer flag,i

C     EXTERNAL FUCNTIONS
      logical IsANumber
      external IsANumber

C     EXTERNAL SUBROUTINES
      external evalfc,reperr

      call evalfc(n,x,f,m,c,flag)

      efccnt = efccnt + 1
      fcnt   = fcnt   + 1

      if ( flag .ne. 0 ) then
          if ( iprintctl(3) ) then
              write(* ,100)
              write(10,100)
          end if

          if ( safemode ) then
              inform = - 98
              call reperr(inform)
              return
          end if
      end if

      if ( .not. IsANumber(f) ) then
          if ( iprintctl(3) ) then
              write(* ,200)
              write(* ,400) f
              write(10,200)
              write(10,400) f
          end if

          if ( safemode ) then
              inform = - 98
              call reperr(inform)
              return
          end if
      end if

      do i = 1,m
          if ( .not. IsANumber(c(i)) ) then
              if ( iprintctl(3) ) then
                  write(* ,300)
                  write(* ,500) n,m,i,c(i)
                  write(10,300)
                  write(10,500) n,m,i,c(i)
              end if

              if ( safemode ) then
                  inform = - 98
                  call reperr(inform)
                  return
              end if
          end if
      end do

C     NON-EXECUTABLE STATEMENTS

 100  format(/,1X,'VEVALFC WARNING: A non-null flag was returned.',/)

 200  format(/,1X,'VEVALFC WARNING: The objective function value ',
     +            'computed by the user-supplied',/,1X,'subroutine ',
     +            'EVALFC is +Inf, -Inf or NaN.')

 300  format(/,1X,'VEVALFC WARNING: The value of a constraint ',
     +            'computed by the user-supplied',/,1X,'subroutine ',
     +            'EVALFC is +Inf, -Inf or NaN.')

 400  format(/,1X,'Value: ',1P,D24.16)

 500  format(/,1X,'Dimension of the space: ',I16,
     +       /,1X,'Number of constraints : ',I16,
     +       /,1X,'Constraint            : ',I16,
     +       /,1X,'Value                 : ',1P,D24.16)

      end

C     ******************************************************************
C     ******************************************************************

      subroutine vevalgjac(n,x,g,m,jcfun,jcvar,jcval,jcnnz,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,jcnnz,m,n

C     ARRAY ARGUMENTS
      integer jcfun(*),jcvar(*)
      double precision g(n),jcval(*),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      character * 6 hptype
      character * 2 innslvr
      logical ccoded,fccoded,fcoded,gcoded,gjaccoded,innercall,jaccoded,
     +        hcoded,hccoded,hlcoded,hlpcoded,firstde,truehl,ignoref,
     +        skipacc,sclsys,useustp,safemode

C     COMMON BLOCKS
      common /algparam/ fcoded,gcoded,hcoded,ccoded,jaccoded,hccoded,
     +                  hlcoded,hlpcoded,fccoded,gjaccoded,firstde,
     +                  truehl,ignoref,skipacc,sclsys,innercall,useustp,
     +                  innslvr,hptype,safemode
      save   /algparam/
C     COMMON SCALARS
      integer efcnt,efccnt,egcnt,egjccnt,ehcnt,ehlcnt,ehlpcnt,fcnt

C     COMMON ARRAYS
      integer eccnt(mmax),ehccnt(mmax),ejccnt(mmax)

C     COMMON BLOCKS
      common /counters/ eccnt,ehccnt,ejccnt,efcnt,efccnt,egcnt,egjccnt,
     +                  ehcnt,ehlcnt,ehlpcnt,fcnt
      save   /counters/
C     COMMON SCALARS
      logical iprintctl(7)
      integer iprintinn,iprintout,mprint,nprint

C     COMMON BLOCKS
      common /outdat/ iprintctl,iprintinn,iprintout,nprint,mprint
      save   /outdat/


C     LOCAL SCALARS
      integer flag,i

C     EXTERNAL FUCNTIONS
      logical IsANumber
      external IsANumber

C     EXTERNAL SUBROUTINES
      external evalgjac,ivevalgjac,reperr

      if ( gjaccoded ) then
          call evalgjac(n,x,g,m,jcfun,jcvar,jcval,jcnnz,flag)

          egjccnt = egjccnt + 1

          if ( flag .ne. 0 ) then
              if ( iprintctl(3) ) then
                  write(* ,100)
                  write(10,100)
              end if

              if ( safemode ) then
                  inform = - 99
                  call reperr(inform)
                  return
              end if
          end if

          do i = 1,n
              if ( .not. IsANumber(g(i)) ) then
                  if ( iprintctl(3) ) then
                      write(* ,300)
                      write(* ,400) n,i,g(i)
                      write(10,300)
                      write(10,400) n,i,g(i)
                  end if

                  if ( safemode ) then
                      inform = - 99
                      call reperr(inform)
                      return
                  end if
              end if
          end do

          do i = 1,jcnnz
              if ( jcfun(i) .lt. 1 .or. jcfun(i) .gt. m .or.
     +             jcvar(i) .lt. 1 .or. jcvar(i) .gt. n ) then

                  if ( iprintctl(3) ) then
                      write(* ,200)
                      write(* ,500) n,m,i,jcfun(i),jcvar(i),jcval(i)
                      write(10,200)
                      write(10,500) n,m,i,jcfun(i),jcvar(i),jcval(i)
                  end if

                  jcfun(i) = 1
                  jcvar(i) = 1
                  jcval(i) = 0.0d0
              end if

              if ( .not. IsANumber(jcval(i)) ) then
                  if ( iprintctl(3) ) then
                      write(* ,300)
                      write(* ,500) n,m,i,jcfun(i),jcvar(i),jcval(i)
                      write(10,300)
                      write(10,500) n,m,i,jcfun(i),jcvar(i),jcval(i)
                  end if

                  if ( safemode ) then
                      inform = - 99
                      call reperr(inform)
                      return
                  end if
              end if
          end do

      else
          call ivevalgjac(n,x,g,m,jcfun,jcvar,jcval,jcnnz,inform)
          if ( inform .lt. 0 ) return
      end if

C     NON-EXECUTABLE STATEMENTS

 100  format(/,1X,'VEVALGJAC WARNING: A non-null flag was returned.',/)

 200  format(/,1X,'VEVALGJAC WARNING: There is an element out of ',
     +            'range in the gradient of the objective function or ',
     +            'in the Jacobian of the constraints computed by the ',
     +            'user-supplied subroutine EVALGJAC. It will be ',
     +            'ignored.')

 300  format(/,1X,'VEVALGJAC WARNING: There is an element whose value ',
     +            'is +Inf, -Inf or NaN in the',/,1X,'gradient of the ',
     +            'objective function or in the Jacobian of the ',
     +            'constraints',/,1X,'computed by the user-supplied ',
     +            'subroutine EVALGJAC.')

 400  format(/,1X,'Dimension of the space: ',I16,
     +       /,1X,'Position              : ',I16,
     +       /,1X,'Value                 : ',1P,D24.16)

 500  format(/,1X,'Dimension of the space: ',I16,
     +       /,1X,'Number of constraints : ',I16,
     +       /,1X,'Position              : ',I16,
     +       /,1X,'Constraint            : ',I16,
     +       /,1X,'Variable              : ',I16,
     +       /,1X,'Value                 : ',1P,D24.16)

      end

C     ******************************************************************
C     ******************************************************************

      subroutine ivevalgjac(n,x,g,m,jcfun,jcvar,jcval,jcnnz,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,jcnnz,m,n

C     ARRAY ARGUMENTS
      integer jcfun(*),jcvar(*)
      double precision g(n),jcval(*),x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      double precision bignum,macheps,macheps12,macheps13,macheps23

C     COMMON BLOCKS
      common /machcon/ bignum,macheps,macheps12,macheps13,macheps23
      save   /machcon/

C     LOCAL SCALARS
      integer i,j
      double precision fminus,fplus,step,tmp

C     LOCAL ARRAYS
      double precision cminus(mmax),cplus(mmax)

C     INTRINSIC FUNCTIONS
      intrinsic abs,max

C     EXTERNAL SUBROUTINES
      external setp,vevalfc

      jcnnz = 0

      do i = 1,n
          tmp  = x(i)

          step = macheps13 * max( 1.0d0, abs( tmp ) )

          x(i) = tmp + step
          call setp(n,x)
          call vevalfc(n,x,fplus,m,cplus,inform)
          if ( inform .lt. 0 ) return

          x(i) = tmp - step
          call setp(n,x)
          call vevalfc(n,x,fminus,m,cminus,inform)
          if ( inform .lt. 0 ) return

          do j = 1,m
              jcfun(jcnnz + 1) = j
              jcvar(jcnnz + 1) = i
              jcval(jcnnz + 1) = ( cplus(j) - cminus(j) ) /
     +                           ( 2.0d0 * step )

              if ( abs( jcval(jcnnz + 1) ) .gt. 0.0d0 ) then
                  jcnnz = jcnnz + 1
              end if
          end do

          g(i) = ( fplus - fminus ) / ( 2.0d0 * step )

          x(i) = tmp
      end do

      end

C     ******************************************************************
C     ******************************************************************

      subroutine reperr(inform)

C     SCALAR ARGUMENTS
      integer inform

C     COMMON SCALARS
      logical iprintctl(7)
      integer iprintinn,iprintout,mprint,nprint

C     COMMON BLOCKS
      common /outdat/ iprintctl,iprintinn,iprintout,nprint,mprint
      save   /outdat/


      if ( iprintctl(3) ) then
          write(* ,100) inform
          write(10,100) inform
      end if

C     NON-EXECUTABLE STATEMENTS

 100  format(/,1X,'*** Safemode is enable. Terminating execution. ***',
     +       /,1X,'*** Error code = ',I3,'***',/)

      end

C     ******************************************************************
C     ******************************************************************

      logical function IsANumber(x)

      implicit none

C     SCALAR ARGUMENTS
      double precision x

C     COMMON SCALARS
      double precision bignum,macheps,macheps12,macheps13,macheps23

C     COMMON BLOCKS
      common /machcon/ bignum,macheps,macheps12,macheps13,macheps23
      save   /machcon/

      IsANumber = .true.

      if ( .not. abs( x ) .le. bignum ) then
          IsANumber = .false.
      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine vsetp(n,x)

      implicit none

C     SCALAR ARGUMENTS
      integer n

C     ARRAY ARGUMENTS
      double precision x(n)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical constrc,gotc

C     COMMON ARRAYS
      integer jcvar(jcnnzmax),jcsta(mmax),jclen(mmax)
      double precision c(mmax),dpdc(mmax),g(nmax),gparc(nmax),
     +        jcval(jcnnzmax)

C     COMMON BLOCKS
      common /gdata/ g,gparc,c,dpdc,jcval,jcvar,jcsta,jclen,constrc,gotc
      save   /gdata/

C     EXTERNAL SUBROUTINES
      external setp

      gotc = .false.

      call setp(n,x)

      end

C     ******************************************************************
C     ******************************************************************

      subroutine vunsetp()

      implicit none

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical constrc,gotc

C     COMMON ARRAYS
      integer jcvar(jcnnzmax),jcsta(mmax),jclen(mmax)
      double precision c(mmax),dpdc(mmax),g(nmax),gparc(nmax),
     +        jcval(jcnnzmax)

C     COMMON BLOCKS
      common /gdata/ g,gparc,c,dpdc,jcval,jcvar,jcsta,jclen,constrc,gotc
      save   /gdata/

C     EXTERNAL SUBROUTINES
      external unsetp

      gotc = .false.

      call unsetp()

      end
C     ******************************************************************
C     ******************************************************************

      double precision function drand(ix)

C     This is the random number generator of Schrage:
C
C     L. Schrage, A more portable Fortran random number generator, ACM
C     Transactions on Mathematical Software 5 (1979), 132-138.

      double precision ix

      double precision a,p,b15,b16,xhi,xalo,leftlo,fhi,k
      data a/16807.d0/,b15/32768.d0/,b16/65536.d0/,p/2147483647.d0/

      xhi= ix/b16
      xhi= xhi - dmod(xhi,1.d0)
      xalo= (ix-xhi*b16)*a
      leftlo= xalo/b16
      leftlo= leftlo - dmod(leftlo,1.d0)
      fhi= xhi*a + leftlo
      k= fhi/b15
      k= k - dmod(k,1.d0)
      ix= (((xalo-leftlo*b16)-p)+(fhi-k*b15)*b16)+k
      if (ix.lt.0) ix= ix + p
      drand= ix*4.656612875d-10

      return

      end

C     ******************************************************************
C     ******************************************************************

      logical function lss(lsssub)

      implicit none

C     SCALAR ARGUMENTS
      character * 4 lsssub

      lsssub = 'MA57'
      lss    = .true.

      return

      end

C     ******************************************************************
C     ******************************************************************

      subroutine lssini(sclsys,acneig,usefac)

      implicit none

C     SCALAR ARGUMENTS
      logical acneig,sclsys,usefac

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical lacneig,lsclsys,lusefac

C     COMMON ARRAYS
      integer icntl(20),iwork(5*nsysmax),posfac(nnzmax),invp(nsysmax),
     +        ifact(nnzmax),keep(nnzmax),info(40)
      double precision cntl(5),work(nsysmax),w(nsysmax),sdiag(nsysmax),
     +        fact(nnzmax),s(nsysmax),rinfo(20)

C     COMMON BLOCKS
      common /lssdat/ cntl,work,w,sdiag,fact,s,rinfo,icntl,iwork,posfac,
     +                invp,ifact,keep,info,lacneig,lsclsys,lusefac
      save   /lssdat/
C     COMMON SCALARS
      double precision bignum,macheps,macheps12,macheps13,macheps23

C     COMMON BLOCKS
      common /machcon/ bignum,macheps,macheps12,macheps13,macheps23
      save   /machcon/

      lacneig = acneig
      lusefac = usefac
      lsclsys = sclsys

      call ma57id(cntl,icntl)

C     Suppress monitoring, warning and error messages
      icntl(5) = 0

C     Chooses AMD pivot ordering using MC47
C     icntl(6) = 0

      if ( lsclsys ) then
          icntl(15) = 1
      else
          icntl(15) = 0
      end if

      if ( .not. lacneig ) then
          icntl(7)  = 2
          icntl(8)  = 1

          cntl(2)   = macheps23
      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine lssana(nsys,hnnz,hlin,hcol,hval,hdiag,lssinfo)

      implicit none

C     SCALAR ARGUMENTS
      integer nsys,hnnz,lssinfo

C     ARRAY ARGUMENTS
      integer hlin(hnnz),hcol(hnnz),hdiag(nsys)
      double precision hval(hnnz)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical iprintctl(7)
      integer iprintinn,iprintout,mprint,nprint

C     COMMON BLOCKS
      common /outdat/ iprintctl,iprintinn,iprintout,nprint,mprint
      save   /outdat/

C     COMMON SCALARS
      logical lacneig,lsclsys,lusefac

C     COMMON ARRAYS
      integer icntl(20),iwork(5*nsysmax),posfac(nnzmax),invp(nsysmax),
     +        ifact(nnzmax),keep(nnzmax),info(40)
      double precision cntl(5),work(nsysmax),w(nsysmax),sdiag(nsysmax),
     +        fact(nnzmax),s(nsysmax),rinfo(20)

C     COMMON BLOCKS
      common /lssdat/ cntl,work,w,sdiag,fact,s,rinfo,icntl,iwork,posfac,
     +                invp,ifact,keep,info,lacneig,lsclsys,lusefac
      save   /lssdat/

      if ( nsys .gt. nsysmax ) then
        ! INSUFFICIENT SPACE TO STORE THE LINEAR SYSTEM

          if ( iprintctl(3) ) then
              write(* ,9000) nsysmax,nsys
              write(10,9000) nsysmax,nsys
          end if

          lssinfo = 6
          return
      end if

      call ma57ad(nsys,hnnz,hlin,hcol,nnzmax,keep,iwork,icntl,info,
     +rinfo)

      if ( info(1) .eq. 0 ) then
        ! SUCCESS

          lssinfo = 0
          return
      end if

C     UNHANDLED ERROR

      if ( iprintctl(3) ) then
          write(* ,9030) info(1)
          write(10,9030) info(1)
      end if

      stop

C     NON-EXECUTABLE STATEMENTS

 9000 format(/,1X,'LSSANA-MA57 WARNING: Insufficient space to store ',
     +            'linear system. Increase',
     +       /,1X,'parameter nsysmax from ',I16,' to at least ',I16,
     +       /,1X,'if you would like to try a direct linear solver ',
     +            'again.')
 9030 format(/,1X,'LSSANA-MA57 ERROR: Unhandled error ',I16,'.',
     +       /,1X,'See documentation for details.')

      end

C     ******************************************************************
C     ******************************************************************

      subroutine lssfac(nsys,hnnz,hlin,hcol,hval,hdiag,d,pind,pval,
     +nneigv,lssinfo)

      implicit none

C     SCALAR ARGUMENTS
      integer nsys,hnnz,pind,nneigv,lssinfo
      double precision pval

C     ARRAY ARGUMENTS
      integer hlin(hnnz),hcol(hnnz),hdiag(nsys)
      double precision hval(hnnz),d(nsys)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical iprintctl(7)
      integer iprintinn,iprintout,mprint,nprint

C     COMMON BLOCKS
      common /outdat/ iprintctl,iprintinn,iprintout,nprint,mprint
      save   /outdat/

C     COMMON SCALARS
      logical lacneig,lsclsys,lusefac

C     COMMON ARRAYS
      integer icntl(20),iwork(5*nsysmax),posfac(nnzmax),invp(nsysmax),
     +        ifact(nnzmax),keep(nnzmax),info(40)
      double precision cntl(5),work(nsysmax),w(nsysmax),sdiag(nsysmax),
     +        fact(nnzmax),s(nsysmax),rinfo(20)

C     COMMON BLOCKS
      common /lssdat/ cntl,work,w,sdiag,fact,s,rinfo,icntl,iwork,posfac,
     +                invp,ifact,keep,info,lacneig,lsclsys,lusefac
      save   /lssdat/

C     LOCAL SCALARS
      integer i,idiag
      double precision d1

      if ( nsys .gt. nsysmax ) then
        ! INSUFFICIENT SPACE TO STORE THE LINEAR SYSTEM

          if ( iprintctl(3) ) then
              write(* ,9000) nsysmax,nsys
              write(10,9000) nsysmax,nsys
          end if

          lssinfo = 6
          return
      end if

      do i = 1,nsys
          idiag       = hdiag(i)
          w(i)        = hval(idiag)
          hval(idiag) = hval(idiag) + d(i)
      end do

      call ma57bd(nsys,hnnz,hval,fact,nnzmax,ifact,nnzmax,nnzmax,
     +keep,iwork,icntl,cntl,info,rinfo)

      if ( lsclsys ) then
          do i = 1,nsys
              s(i) = fact(nnzmax-nsys-1+i)
          end do
      end if

      do i = 1,nsys
          idiag       = hdiag(i)
          hval(idiag) = w(i)
      end do

      if ( info(1) .eq. 0 ) then

          d1 = hval(hdiag(1)) + d(1)

          if ( d1 .gt. 0.0d0 ) then
            ! SUCCESS

              lssinfo = 0
          else
            ! MATRIX IS NEGATIVE DEFINITE

              pind    = 1
              pval    = abs( d1 )

              lssinfo = 1
          end if

      else if ( info(1) .eq. 5 .or. info(1) .eq. -6 ) then
        ! MATRIX NOT POSITIVE DEFINITE

          pind    = info(2)
          pval    = abs( rinfo(20) )

          lssinfo = 1

      else if ( info(1) .eq. 4 .or. info(1) .eq. -5 ) then
        ! RANK DEFICIENT MATRIX

          pind    = info(2)
          pval    = abs( rinfo(20) )

          lssinfo = 2

      else if ( info(1) .eq. -3 ) then
        ! INSUFFICIENT DOUBLE PRECISION WORKING SPACE

          if ( iprintctl(3) ) then
              write(* ,9010) nnzmax,info(17)
              write(10,9010) nnzmax,info(17)
          end if

          lssinfo = 7

      else if ( info(1) .eq. -4 ) then
        ! INSUFFICIENT INTEGER WORKING SPACE

          if ( iprintctl(3) ) then
              write(* ,9020) nnzmax,info(18)
              write(10,9020) nnzmax,info(18)
          end if

          lssinfo = 8

      else
        ! UNHANDLED ERROR

          if ( iprintctl(3) ) then
              write(* ,9030) info(1)
              write(10,9030) info(1)
          end if

          stop

      end if

C     NUMBER OF NEGATIVE EIGENVALUES
      nneigv = info(24)

      if ( lusefac .and. lssinfo .eq. 0 ) then

C        Define matrix D^{-1} (stored in sdiag)

          do i = 1,nsys
              w(i) = 0.0d0
          end do

          do i = 1,nsys

              w(i) = 1.0d0

              call ma57cd(3,nsys,fact,nnzmax,ifact,nnzmax,1,w,nsys,
     +        work,nsysmax,iwork,icntl,info)

              sdiag(i) = w(i)
              w(i)     = 0.0d0
          end do

      end if

C     NON-EXECUTABLE STATEMENTS

 9000 format(/,1X,'LSSFAC-MA57 WARNING: Insufficient space to store ',
     +            'linear system. Increase',
     +       /,1X,'parameter nsysmax from ',I16,' to at least ',I16,
     +       /,1X,'if you would like to try a direct linear solver ',
     +            'again.')
 9010 format(/,1X,'LSSFAC-MA57 WARNING: Insufficient double precision ',
     +            'working space. Increase',
     +       /,1X,'parameter nnzmax from ',I16,' to at least ',I16,
     +       /,1X,'if you would like to try a direct linear solver ',
     +            'again.')
 9020 format(/,1X,'LSSFAC-MA57 WARNING: Insufficient integer working ',
     +            'space. Increase',
     +       /,1X,'parameter nnzmax from ',I16,' to at least ',I16,
     +       /,1X,'if you would like to try a direct linear solver ',
     +            'again.')
 9030 format(/,1X,'LSSFAC-MA57 ERROR: Unhandled error ',I16,'.',
     +       /,1X,'See documentation for details.')

      end

C     ******************************************************************
C     ******************************************************************

      subroutine lsssol(nsys,sol)

      implicit none

C     SCALAR ARGUMENTS
      integer nsys

C     ARRAY ARGUMENTS
      double precision sol(nsys)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical lacneig,lsclsys,lusefac

C     COMMON ARRAYS
      integer icntl(20),iwork(5*nsysmax),posfac(nnzmax),invp(nsysmax),
     +        ifact(nnzmax),keep(nnzmax),info(40)
      double precision cntl(5),work(nsysmax),w(nsysmax),sdiag(nsysmax),
     +        fact(nnzmax),s(nsysmax),rinfo(20)

C     COMMON BLOCKS
      common /lssdat/ cntl,work,w,sdiag,fact,s,rinfo,icntl,iwork,posfac,
     +                invp,ifact,keep,info,lacneig,lsclsys,lusefac
      save   /lssdat/

      call ma57cd(1,nsys,fact,nnzmax,ifact,nnzmax,1,sol,nsys,work,
     +nsysmax,iwork,icntl,info)

      end

C     ******************************************************************
C     ******************************************************************

      subroutine lsssoltr(job,nsys,sol)

      implicit none

C     SCALAR ARGUMENTS
      character * 1 job
      integer nsys

C     ARRAY ARGUMENTS
      double precision sol(nsys)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical lacneig,lsclsys,lusefac

C     COMMON ARRAYS
      integer icntl(20),iwork(5*nsysmax),posfac(nnzmax),invp(nsysmax),
     +        ifact(nnzmax),keep(nnzmax),info(40)
      double precision cntl(5),work(nsysmax),w(nsysmax),sdiag(nsysmax),
     +        fact(nnzmax),s(nsysmax),rinfo(20)

C     COMMON BLOCKS
      common /lssdat/ cntl,work,w,sdiag,fact,s,rinfo,icntl,iwork,posfac,
     +                invp,ifact,keep,info,lacneig,lsclsys,lusefac
      save   /lssdat/

C     LOCAL SCALARS
      integer i

      if ( job .eq. 'T' .or. job .eq. 't' ) then

          call ma57cd(2,nsys,fact,nnzmax,ifact,nnzmax,1,sol,nsys,work,
     +    nsysmax,iwork,icntl,info)

          do i = 1,nsys
              sol(i) = sol(i) * sqrt( sdiag(i) )
          end do

          do i = 1,nsys
              work(i) = sol(i)
          end do

          do i = 1,nsys
              sol(keep(i)) = work(i)
          end do

      else

          do i = 1,nsys
              work(i) = sol(i)
          end do

          do i = 1,nsys
              sol(keep(i)) = work(i)
          end do

          do i = 1,nsys
              sol(i) = sol(i) * sqrt( sdiag(i) )
          end do

          call ma57cd(4,nsys,fact,nnzmax,ifact,nnzmax,1,sol,nsys,work,
     +    nsysmax,iwork,icntl,info)

      end if

      end

C     ******************************************************************
C     ******************************************************************

      subroutine lsspermvec(nsys,v)

      implicit none

C     SCALAR ARGUMENTS
      integer nsys

C     ARRAY ARGUMENTS
      integer v(nsys)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical lacneig,lsclsys,lusefac

C     COMMON ARRAYS
      integer icntl(20),iwork(5*nsysmax),posfac(nnzmax),invp(nsysmax),
     +        ifact(nnzmax),keep(nnzmax),info(40)
      double precision cntl(5),work(nsysmax),w(nsysmax),sdiag(nsysmax),
     +        fact(nnzmax),s(nsysmax),rinfo(20)

C     COMMON BLOCKS
      common /lssdat/ cntl,work,w,sdiag,fact,s,rinfo,icntl,iwork,posfac,
     +                invp,ifact,keep,info,lacneig,lsclsys,lusefac
      save   /lssdat/

C     LOCAL SCALARS
      integer i

      do i = 1,nsys
          iwork(keep(i)) = v(i)
      end do

      do i = 1,nsys
          v(i) = iwork(i)
      end do

      end

C     ******************************************************************
C     ******************************************************************

      subroutine lssunpermvec(nsys,v)

      implicit none

C     SCALAR ARGUMENTS
      integer nsys

C     ARRAY ARGUMENTS
      integer v(nsys)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical lacneig,lsclsys,lusefac

C     COMMON ARRAYS
      integer icntl(20),iwork(5*nsysmax),posfac(nnzmax),invp(nsysmax),
     +        ifact(nnzmax),keep(nnzmax),info(40)
      double precision cntl(5),work(nsysmax),w(nsysmax),sdiag(nsysmax),
     +        fact(nnzmax),s(nsysmax),rinfo(20)

C     COMMON BLOCKS
      common /lssdat/ cntl,work,w,sdiag,fact,s,rinfo,icntl,iwork,posfac,
     +                invp,ifact,keep,info,lacneig,lsclsys,lusefac
      save   /lssdat/

C     LOCAL SCALARS
      integer i

      do i = 1,nsys
          iwork(i) = v(keep(i))
      end do

      do i = 1,nsys
          v(i) = iwork(i)
      end do

      end

C     ******************************************************************
C     ******************************************************************

      subroutine lsspermind(hnnz,hlin,hcol)

      implicit none

C     SCALAR ARGUMENTS
      integer hnnz

C     ARRAY ARGUMENTS
      integer hlin(hnnz),hcol(hnnz)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical lacneig,lsclsys,lusefac

C     COMMON ARRAYS
      integer icntl(20),iwork(5*nsysmax),posfac(nnzmax),invp(nsysmax),
     +        ifact(nnzmax),keep(nnzmax),info(40)
      double precision cntl(5),work(nsysmax),w(nsysmax),sdiag(nsysmax),
     +        fact(nnzmax),s(nsysmax),rinfo(20)

C     COMMON BLOCKS
      common /lssdat/ cntl,work,w,sdiag,fact,s,rinfo,icntl,iwork,posfac,
     +                invp,ifact,keep,info,lacneig,lsclsys,lusefac
      save   /lssdat/

C     LOCAL SCALARS
      integer col,i,lin

      do i = 1,hnnz
          col = hcol(i)
          lin = hlin(i)

          hcol(i) = keep(col)
          hlin(i) = keep(lin)
      end do

      end

C     ******************************************************************
C     ******************************************************************

      subroutine lssunpermind(nsys,hnnz,hlin,hcol)

      implicit none

C     SCALAR ARGUMENTS
      integer nsys,hnnz

C     ARRAY ARGUMENTS
      integer hlin(hnnz),hcol(hnnz)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical lacneig,lsclsys,lusefac

C     COMMON ARRAYS
      integer icntl(20),iwork(5*nsysmax),posfac(nnzmax),invp(nsysmax),
     +        ifact(nnzmax),keep(nnzmax),info(40)
      double precision cntl(5),work(nsysmax),w(nsysmax),sdiag(nsysmax),
     +        fact(nnzmax),s(nsysmax),rinfo(20)

C     COMMON BLOCKS
      common /lssdat/ cntl,work,w,sdiag,fact,s,rinfo,icntl,iwork,posfac,
     +                invp,ifact,keep,info,lacneig,lsclsys,lusefac
      save   /lssdat/

C     LOCAL SCALARS
      integer col,i,lin

      do i = 1,nsys
          invp(i)=0
      end do

      do i = 1,nsys
          invp(keep(i)) = i
      end do

      do i = 1,hnnz
          col = hcol(i)
          lin = hlin(i)

          hcol(i) = invp(col)
          hlin(i) = invp(lin)
      end do

      end

C     ******************************************************************
C     ******************************************************************

      double precision function lssgetd(j)

      implicit none

C     SCALAR ARGUMENTS
      integer j

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical lacneig,lsclsys,lusefac

C     COMMON ARRAYS
      integer icntl(20),iwork(5*nsysmax),posfac(nnzmax),invp(nsysmax),
     +        ifact(nnzmax),keep(nnzmax),info(40)
      double precision cntl(5),work(nsysmax),w(nsysmax),sdiag(nsysmax),
     +        fact(nnzmax),s(nsysmax),rinfo(20)

C     COMMON BLOCKS
      common /lssdat/ cntl,work,w,sdiag,fact,s,rinfo,icntl,iwork,posfac,
     +                invp,ifact,keep,info,lacneig,lsclsys,lusefac
      save   /lssdat/

      lssgetd = sqrt( 1.0d0 / sdiag(invp(j)) )

      return

      end

C     ******************************************************************
C     ******************************************************************

      subroutine lsssetrow(nsys)

      implicit none

C     SCALAR ARGUMENTS
      integer nsys

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical lacneig,lsclsys,lusefac

C     COMMON ARRAYS
      integer icntl(20),iwork(5*nsysmax),posfac(nnzmax),invp(nsysmax),
     +        ifact(nnzmax),keep(nnzmax),info(40)
      double precision cntl(5),work(nsysmax),w(nsysmax),sdiag(nsysmax),
     +        fact(nnzmax),s(nsysmax),rinfo(20)

C     COMMON BLOCKS
      common /lssdat/ cntl,work,w,sdiag,fact,s,rinfo,icntl,iwork,posfac,
     +                invp,ifact,keep,info,lacneig,lsclsys,lusefac
      save   /lssdat/

C     LOCAL SCALARS
      integer apos,i,nblk,iblk,ipiv,ix,iwpos,j1,j2,k,ncols,nrows,totlen,
     +        nsys2

C     Count the number of elements of fact and ifact used to form each
C     row of L^T

      totlen  = 0
      nsys2   = 2*nsys

      do i = 1,nsys
          iwork(nsys+i) = 0
      end do

      do i = 1,nsys
          iwork(nsys2+i) = 0
      end do

      do i = 1,nsys
          iwork(i) = 0
      end do

      apos  = 1
      iwpos = 4
      nblk  = ifact(3)

      do iblk = 1,nblk
          ncols = ifact(iwpos)
          nrows = ifact(iwpos+1)
          iwpos = iwpos + 2
          j1    = iwpos
          j2    = iwpos + nrows - 1

          do ipiv = 1,nrows
              apos = apos + 1
              ix   = abs( ifact(j1) )
              k    = apos

              if ( j1+1 .le. j2 ) then
                  iwork(nsys2+ix) = iwork(nsys2+ix) + 3
                  totlen          = totlen + 3
              end if

              k    = max( k, k+j2-j1 )
              apos = k
              j1   = j1 + 1
          end do

          j2 = iwpos + ncols - 1

          do ipiv = 1,nrows-1,2
              k  = apos
              ix = abs( ifact(iwpos+ipiv-1) )

              if ( j1 .le. j2 ) then
                  iwork(nsys2+ix) = iwork(nsys2+ix) + 3
                  totlen          = totlen + 3
              end if

              k  = apos+ncols-nrows
              ix = abs( ifact(iwpos+ipiv) )

              if ( j1 .le. j2 ) then
                  iwork(nsys2+ix) = iwork(nsys2+ix) + 3
                  totlen          = totlen + 3
              end if

              k    = max( k, k+j2-j1+1 )
              apos = k
          end do

          if ( mod(nrows,2) .eq. 1 ) then
              k  = apos
              ix = abs( ifact(iwpos+ipiv-1) )

              if ( j1 .le. j2 ) then
                  iwork(nsys2+ix) = iwork(nsys2+ix) + 3
                  totlen          = totlen + 3
              end if

              k    = max( k, k+j2-j1+1 )
              apos = k
          end if

          iwpos = iwpos + ncols

      end do

      iwork(nsys+1) = 1

      do i = 2,nsys
          iwork(nsys+i) = iwork(nsys+i-1) + iwork(nsys2+i-1)
      end do

      do i = 1,nsys
          iwork(i) = iwork(nsys+i)
      end do

C     Store the indices of elements of fact and ifact used to form each
C     row of L^T

      apos  = 1
      iwpos = 4
      nblk  = ifact(3)

      do iblk = 1,nblk
          ncols = ifact(iwpos)
          nrows = ifact(iwpos+1)
          iwpos = iwpos + 2
          j1    = iwpos
          j2    = iwpos + nrows - 1

          do ipiv = 1,nrows
              apos = apos + 1
              ix   = abs( ifact(j1) )
              k    = apos

              if ( j1+1 .le. j2 ) then
                  posfac(iwork(ix))   = j1+1
                  posfac(iwork(ix)+1) = j2
                  posfac(iwork(ix)+2) = k
                  iwork(ix)           = iwork(ix)+3
              end if

              k   = max( k, k+j2-j1 )
              apos = k
              j1   = j1 + 1
          end do

          j2 = iwpos + ncols - 1

          do ipiv = 1,nrows-1,2
              k  = apos
              ix = abs( ifact(iwpos+ipiv-1) )

              if ( j1 .le. j2 ) then
                  posfac(iwork(ix))   = j1
                  posfac(iwork(ix)+1) = j2
                  posfac(iwork(ix)+2) = -k
                  iwork(ix)           = iwork(ix)+3
              end if

              k  = apos+ncols-nrows
              ix = abs( ifact(iwpos+ipiv) )

              if ( j1 .le. j2 ) then
                  posfac(iwork(ix))   = j1
                  posfac(iwork(ix)+1) = j2
                  posfac(iwork(ix)+2) = -k
                  iwork(ix)           = iwork(ix)+3
              end if

              k    = max( k, k+j2-j1+1 )
              apos = k
          end do

          if ( mod(nrows,2) .eq. 1 ) then
              k  = apos
              ix = abs( ifact(iwpos+ipiv-1) )

              if ( j1 .le. j2 ) then
                  posfac(iwork(ix))   = j1
                  posfac(iwork(ix)+1) = j2
                  posfac(iwork(ix)+2) = -k
                  iwork(ix)           = iwork(ix)+3
              end if

              k    = max( k, k+j2-j1+1 )
              apos = k
          end if

          iwpos = iwpos + ncols

      end do

C     Array of null elements

      do i = 1,nsys
          iwork(i) = 0
      end do

C     Compute inverse permutation

      do i = 1,nsys
          invp(keep(i)) = i
      end do

      end

C     ******************************************************************
C     ******************************************************************

      subroutine lssgetrow(nsys,idx,rownnz,rowind,rowval)

      implicit none

C     SCALAR ARGUMENTS
      integer nsys,idx,rownnz

C     ARRAY ARGUMENTS
      integer rowind(nsys)
      double precision rowval(nsys)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical lacneig,lsclsys,lusefac

C     COMMON ARRAYS
      integer icntl(20),iwork(5*nsysmax),posfac(nnzmax),invp(nsysmax),
     +        ifact(nnzmax),keep(nnzmax),info(40)
      double precision cntl(5),work(nsysmax),w(nsysmax),sdiag(nsysmax),
     +        fact(nnzmax),s(nsysmax),rinfo(20)

C     COMMON BLOCKS
      common /lssdat/ cntl,work,w,sdiag,fact,s,rinfo,icntl,iwork,posfac,
     +                invp,ifact,keep,info,lacneig,lsclsys,lusefac
      save   /lssdat/

C     LOCAL SCALARS
      integer i,j,j1,j2,k,ind,ista,iend,ix
      double precision sclf

      ind  = invp(idx)
      ista = iwork(nsys+ind)
      iend = ista + iwork(2*nsys+ind) - 1

      if ( lsclsys ) then
          sclf = s(ind)
      else
          sclf = 1.0d0
      end if

      rownnz         = 1
      rowind(rownnz) = ind
      rowval(rownnz) = sclf
      iwork(ind)     = rownnz

      do i = ista,iend,3
          j1 = posfac(i)
          j2 = posfac(i+1)
          k  = posfac(i+2)

          if ( k .gt. 0 ) then

              do j = j1,j2
                  ix = abs( ifact(j) )

                  if ( iwork(ix) .eq. 0 ) then
                      if ( fact(k) .ne. 0.0d0 ) then
                          rownnz         = rownnz + 1
                          rowind(rownnz) = ix
                          rowval(rownnz) = sclf * fact(k)
                          iwork(ix)      = rownnz
                      end if
                  else
                      rowval(iwork(ix)) =
     +                rowval(iwork(ix)) + sclf * fact(k)
                  end if

                  k = k + 1
              end do
          else
              k = abs( k )

              do j = j1,j2
                  ix = abs( ifact(j) )

                  if ( iwork(ix) .eq. 0 ) then
                      if ( fact(k) .ne. 0.0d0 ) then
                          rownnz         = rownnz + 1
                          rowind(rownnz) = ix
                          rowval(rownnz) = - sclf * fact(k)
                          iwork(ix)      = rownnz
                      end if
                  else
                      rowval(iwork(ix)) =
     +                rowval(iwork(ix)) - sclf * fact(k)
                  end if

                  k = k + 1
              end do
          end if
      end do

      if ( lsclsys ) then
          do i = 1,rownnz
              rowval(i) = rowval(i) / s(rowind(i))
          end do
      end if

C     Set used positions of iwork back to 0

      do i = 1,rownnz
          iwork(rowind(i)) = 0
      end do

      do i = 1,rownnz
          rowval(i) = rowval(i) / sqrt( sdiag(ind) )
      end do

      do i = 1,rownnz
          rowind(i) = keep(rowind(i))
      end do

      end

C     ******************************************************************
C     ******************************************************************

      subroutine lssafsol(nsys,hnnz,hlin,hcol,hval,hdiag,d,sol,lssinfo)

      implicit none

C     SCALAR ARGUMENTS
      integer nsys,hnnz,lssinfo

C     ARRAY ARGUMENTS
      integer hlin(hnnz),hcol(hnnz),hdiag(nsys)
      double precision hval(hnnz),d(nsys),sol(nsys)

C     PARAMETERS

      integer mmax,nmax,nsmax,nsysmax,nnzmax,jcnnzmax,hnnzmax

      parameter ( mmax      =   500000 )
      parameter ( nmax      =   500000 )
      parameter ( nsmax     =     1000 )
      parameter ( nsysmax   =   500000 )
      parameter ( nnzmax    = 10000000 )
      parameter ( jcnnzmax  = 10000000 )
      parameter ( hnnzmax   = 10000000 )
C     COMMON SCALARS
      logical iprintctl(7)
      integer iprintinn,iprintout,mprint,nprint

C     COMMON BLOCKS
      common /outdat/ iprintctl,iprintinn,iprintout,nprint,mprint
      save   /outdat/

C     COMMON SCALARS
      logical lacneig,lsclsys,lusefac

C     COMMON ARRAYS
      integer icntl(20),iwork(5*nsysmax),posfac(nnzmax),invp(nsysmax),
     +        ifact(nnzmax),keep(nnzmax),info(40)
      double precision cntl(5),work(nsysmax),w(nsysmax),sdiag(nsysmax),
     +        fact(nnzmax),s(nsysmax),rinfo(20)

C     COMMON BLOCKS
      common /lssdat/ cntl,work,w,sdiag,fact,s,rinfo,icntl,iwork,posfac,
     +                invp,ifact,keep,info,lacneig,lsclsys,lusefac
      save   /lssdat/

C     LOCAL SCALARS
      integer i,tmp

C     LOCAL ARRAYS
      integer keeptmp(nnzmax),infotmp(40)
      double precision rinfotmp(20)

      tmp       = icntl(15)
      icntl(15) = 0

      if ( nsys .gt. nsysmax ) then
        ! INSUFFICIENT SPACE TO STORE THE LINEAR SYSTEM

          lssinfo = 6

          if ( iprintctl(3) ) then
              write(* ,9000) nsysmax,nsys
              write(10,9000) nsysmax,nsys
          end if

          go to 500

      end if

      call ma57ad(nsys,hnnz,hlin,hcol,nnzmax,keeptmp,iwork,icntl,
     +infotmp,rinfotmp)

      if ( ( infotmp(1) .eq. 0 ) .or. ( infotmp(1) .eq. 1 ) ) then
        ! SUCCESS

          lssinfo = 0

      else
        ! UNHANDLED ERROR

          if ( iprintctl(3) ) then
              write(* ,9030) infotmp(1)
              write(10,9030) infotmp(1)
          end if

          stop

      end if

      do i = 1,nsys
          hval(hdiag(i)) = hval(hdiag(i)) + d(i)
      end do

      if ( lsclsys ) then
          do i = 1,hnnz
              hval(i) = hval(i) * s(hlin(i)) * s(hcol(i))
          end do
      end if

      call ma57bd(nsys,hnnz,hval,fact,nnzmax,ifact,nnzmax,nnzmax,
     +keeptmp,iwork,icntl,cntl,infotmp,rinfotmp)

      if ( lsclsys ) then
          do i = 1,hnnz
              hval(i) = hval(i) * s(hlin(i)) * s(hcol(i))
          end do
      end if

      do i = 1,nsys
          hval(hdiag(i)) = hval(hdiag(i)) - d(i)
      end do

      if ( ( infotmp(1) .eq. 0 ) .or. ( infotmp(1) .eq. 1 ) ) then
        ! SUCCESS

          lssinfo = 0

      else if ( info(1) .eq. 5 .or. info(1) .eq. -6 ) then
        ! MATRIX NOT POSITIVE DEFINITE

          lssinfo = 1

      else if ( infotmp(1) .eq. 4 .or. infotmp(1) .eq. -5 ) then
        ! RANK DEFICIENT MATRIX

          lssinfo = 2

      else if ( infotmp(1) .eq. -3 ) then
        ! INSUFFICIENT DOUBLE PRECISION WORKING SPACE

          lssinfo = 7

          if ( iprintctl(3) ) then
              write(* ,9010) nnzmax,infotmp(17)
              write(10,9010) nnzmax,infotmp(17)
          end if

          go to 500

      else if ( infotmp(1) .eq. -4 ) then
        ! INSUFFICIENT INTEGER WORKING SPACE

          lssinfo = 8

          if ( iprintctl(3) ) then
              write(* ,9020) nnzmax,infotmp(18)
              write(10,9020) nnzmax,infotmp(18)
          end if

          go to 500

      else
        ! UNHANDLED ERROR

          if ( iprintctl(3) ) then
              write(* ,9030) infotmp(1)
              write(10,9030) infotmp(1)
          end if

          stop

      end if

      if ( lsclsys ) then
          do i = 1,nsys
              sol(i) = sol(i) * s(i)
          end do
      end if

      call ma57cd(1,nsys,fact,nnzmax,ifact,nnzmax,1,sol,nsys,work,
     +nsysmax,iwork,icntl,infotmp)

      if ( lsclsys ) then
          do i = 1,nsys
              sol(i) = sol(i) * s(i)
          end do
      end if

 500  continue

      icntl(15) = tmp

C     NON-EXECUTABLE STATEMENTS

 9000 format(/,1X,'LSSAFSOL-MA57 WARNING: Insufficient space to store ',
     +            'linear system. Increase',
     +       /,1X,'parameter nsysmax from ',I16,' to at least ',I16,
     +       /,1X,'if you would like to try a direct linear solver ',
     +            'again.')
 9010 format(/,1X,'LSSAFSOL-MA57 WARNING: Insufficient double ',
     +            'precision working space. Increase',
     +       /,1X,'parameter nnzmax from ',I16,' to at least ',I16,
     +       /,1X,'if you would like to try a direct linear solver ',
     +            'again.')
 9020 format(/,1X,'LSSAFSOL-MA57 WARNING: Insufficient integer ',
     +            'working space. Increase',
     +       /,1X,'parameter nnzmax from ',I16,' to at least ',I16,
     +       /,1X,'if you would like to try a direct linear solver ',
     +            'again.')
 9030 format(/,1X,'LSSAFSOL-MA57 ERROR: Unhandled error ',I16,'.',
     +       /,1X,'See documentation for details.')

      end
C     sclinfo:
C
C     0: Success.
C     1: Invalid row or column index.
C     2: Duplicate entry.
C     6: Insufficient space to store the input matrix.
C     7: Insufficient double precision working space.

C     ******************************************************************
C     ******************************************************************

      logical function scl(sclsub)

      implicit none

C     SCALAR ARGUMENTS
      character * 4 sclsub

      scl = .false.
      return

      end

C     ******************************************************************
C     ******************************************************************

      subroutine sclini()

      implicit none

      end

C     ******************************************************************
C     ******************************************************************

      subroutine sclana(nsys,hnnz,hlin,hcol,hval,hdiag,sclinfo)

      implicit none

C     SCALAR ARGUMENTS
      integer nsys,hnnz,sclinfo

C     ARRAY ARGUMENTS
      integer hlin(hnnz),hcol(hnnz),hdiag(nsys)
      double precision hval(hnnz)

      end

C     ******************************************************************
C     ******************************************************************

      subroutine sclsys(nsys,hnnz,hlin,hcol,hval,s,sclinfo)

      implicit none

C     SCALAR ARGUMENTS
      integer nsys,hnnz,sclinfo

C     ARRAY ARGUMENTS
      integer hlin(hnnz),hcol(hnnz)
      double precision hval(hnnz),s(nsys)

      end


