C     =================================================================
C     File: genlin.f
C     =================================================================

C     =================================================================
C     Module: Auxiliary subroutines
C     =================================================================

C     Last update of any of the component of this module: 
C
C     May 1st, 2008.

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

      subroutine solver(n,x,l,u,ml,mleq,lda,A,b,gtype,hptype,intype,
     +precond,checkder,lossfeas,epsfeas,epsopt,maxtotit,maxtotfc,iprint,
     +ncomp,mlcomp,f,cnorm,gpsupn,totiter,totfcnt,totgcnt,tothcnt,
     +totcgcnt,totchcnt,time,inform,wi1,wi2,wi3,wi4,wi5,wd1,wd2,wd3,wd4,
     +wd5,wd6,wd7,wd8,wd9,wd10,wd11,wd12,wd13,wd14,wd15,wd16,wd17,wd18,
     +wd19,wd20,wd21,wd22,wd23,wd24,lwd24,ldabar,Abar,ldh,H)

      implicit none

C     This subroutine: 
C
C     (1) Computes some machine-dependent constants. 
C
C     (2) Process the optionally input specification file genlin.dat. 
C
C     (3) Check analytic derivatives if desired by the user.
C
C     (4) Open and close the output file genlin.out. 
C
C     (5) Computes the CPU elapsed time used by the solver.
C
C     (6) Calls the solver (GENLIN).
C
C     (7) Write an output file called solution.txt with the solution.

C     SCALAR ARGUMENTS
      logical checkder,lossfeas
      character * 6 precond
      integer gtype,hptype,intype,inform,iprint,ml,mleq,maxtotfc,
     +        maxtotit,n,ncomp,mlcomp,totcgcnt,totfcnt,totgcnt,totiter,
     +        totchcnt,tothcnt,lda,ldabar,ldh,lwd24
      double precision epsfeas,epsopt,f,gpsupn,cnorm
      real time

C     ARRAY ARGUMENTS
      integer wi1(n),wi2(n),wi3(ml),wi4(2*n+ml),wi5(n+ml)
      double precision l(n),u(n),wd1(n),wd2(n),wd3(n),wd4(n),wd5(n),
     +        wd6(n),wd7(n),wd8(n),wd9(n),wd10(n),wd11(n),wd12(n),
     +        wd13(n),wd14(n),wd15(n),wd16(n),wd17(n),wd18(n),wd19(n),
     +        wd20(n),wd21(n),wd22(ml),wd23(ml),wd24(lwd24),x(n),
     +        A(lda,n),Abar(ldabar,ml),H(ldh,n),b(ml)

C     LOCAL SCALARS
      integer i
      integer totspgiter,totspgfcnt,tottniter,tottnfcnt,tottriter,
     +        tottrfcnt,totispgiter,totispgfcnt,totiterql
      double precision bignum,macheps
C     double precision d1mach

C     DECLARATIONS RELATED TO THE TIME MEASUREMENT USING DTIME
      real dtime
      external dtime

      real dum(2)
      data dum/0.0,0.0/

C     COMPUTE MACHINE-DEPENDENT CONSTANTS

      bignum = 1.0d+99

C     macheps = d1mach(4)
      macheps = 1.0d-16

C     OPEN THE OUTPUT FILE

      open(10,file='genlin.out')

C     SET SOME SOLVER ARGUMENTS USING THE SPECIFICATION FILE

      call fparam(gtype,hptype,intype,precond,checkder,lossfeas,epsfeas,
     +epsopt,maxtotit,maxtotfc,iprint,ncomp,mlcomp)

C     TEST DERIVATIVES

#ifndef CUTEr

      if ( checkder ) then
          call checkd(n,l,u,wd1,wd2,wd3,wd4,macheps,inform)

          if ( inform .lt. 0 ) then
              if ( iprint .ge. 1 ) then
                  write(*, 2000) inform
                  write(10,2000) inform
              end if

              go to 500
          end if
      end if

#endif

      time = dtime(dum)
      
C     CALL THE LINEAR-CONSTRAINTS SOLVER GENLIN
      
      call easygenlin(n,x,l,u,ml,mleq,lda,A,b,gtype,hptype,intype,
     +precond,epsopt,epsfeas,lossfeas,maxtotit,maxtotfc,iprint,ncomp,
     +mlcomp,macheps,bignum,f,wd1,gpsupn,cnorm,totiter,totfcnt,totgcnt,
     +tothcnt,totcgcnt,totchcnt,totspgiter,totspgfcnt,tottniter,
     +tottnfcnt,tottriter,tottrfcnt,totispgiter,totispgfcnt,totiterql,
     +inform,ldabar,Abar,ldh,H,wi1,wi2,wi3,wi4,wi5,wd2,wd3,wd4,wd5,wd6,
     +wd7,wd8,wd9,wd10,wd11,wd12,wd13,wd14,wd15,wd16,wd17,wd18,wd19,
     +wd20,wd21,wd22,wd23,wd24,lwd24)
      
      if ( inform .lt. 0 ) then
         if ( iprint .ge. 1 ) then
            write(*, 2000) inform
            write(10,2000) inform
         end if
      end if

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

C     CLOSE THE OUTPUT FILE

      close(10)

C     SAVE THE SOLUTION

      open(10,file='solution.txt')

C     Solution point
      write(10,9000)
      do i = 1,n
          write(10,9010) i,x(i)
      end do

      close(10)

C     WRITE STATISTICS

      open(10,file='genlin-tabline.out')
      write(10,9050) time,inform,n,ml,totiter,totfcnt,totgcnt,tothcnt,
     +totcgcnt,totchcnt,totspgiter,totspgfcnt,tottniter,tottnfcnt,
     +tottriter,tottrfcnt,totispgiter,totispgfcnt,totiterql,f,cnorm,
     +gpsupn
      close(10)
C     RETURN

 500  continue

C     NON-EXECUTABLE STATEMENTS

 2000 format(/,' Flag of GENLIN = ',I3,' Fatal Error',/,
     +       /,' The following codes means: ',/,
     +       /,' -30 : error in projection subroutine', 
     +       /,' -40 : point is infeasible', 
     +       /,' -50 : error in QR decomposition', 
     +       /,' -70 : some linear constraints are inconsistent', 
     +       /,' -90 : error in evalf   subroutine', 
     +       /,' -92 : error in evalg   subroutine', 
     +       /,' -94 : error in evalh   subroutine', 
     +       /,' -96 : error in evalhlp subroutine',/) 
 9000 format(/,'FINAL POINT:',//,2X,'INDEX',16X,'X(INDEX)')
 9010 format(  I7,1P,D24.16)
 9050 format(F8.2,1X,I3,1X,I6,1X,I6,1X,I7,1X,I7,1X,I7,1X,I7,1X,I10,1X,
     +       I10,1X,I10,1X,I10,1X,I10,1X,I10,1X,I10,1X,I10,1X,I10,1X,
     +       I10,1X,I10,1X,1P,D24.16,1X,1P,D7.1,1X,1P,D7.1)

      end

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

      subroutine fparam(gtype,hptype,intype,precond,checkder,lossfeas,
     +epsfeas,epsopt,maxtotit,maxtotfc,iprint,ncomp,mlcomp)

      implicit none

C     This subroutine set some genlin arguments related to stopping 
C     criteria and output. The setting values are taken fron file 
C     genlin.dat. Nothing is done if the file does not exist. File 
C     genlin.dat is an alternative to run GENLIN several times 
C     with different arguments without having to compile it again.

C     SCALAR ARGUMENTS
      logical checkder,lossfeas
      character * 6 precond
      integer gtype,hptype,intype,iprint,maxtotfc,maxtotit,ncomp,mlcomp
      double precision epsfeas,epsopt

C     Parameters of the subroutine:
C     =============================
C
C     The parameters of this subroutine are the same parameters of
C     subroutine param. See the description of them in subroutine 
C     param.

C     PARAMETERS
      integer nwords
      parameter ( nwords = 20 )

C     DATA BLOCKS
      character * 1 lower(26),upper(26)
      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'/

      character * 10 dictionary(nwords)
      data dictionary( 1) /'ANALYTIC-G'/
      data dictionary( 2) /'FINITE-DIF'/
      data dictionary( 3) /'HESSIANS-P'/
      data dictionary( 4) /'LAGRHESS-P'/
      data dictionary( 5) /'INCREMENTA'/
      data dictionary( 6) /'BFGS-QN-AP'/
      data dictionary( 7) /'ADAPTIVE-H'/
      data dictionary( 8) /'GENCAN-BDS'/
      data dictionary( 9) /'BETRA-BDSO'/
      data dictionary(10) /'UNPRECONDI'/
      data dictionary(11) /'BFGS-QN-PR'/
      data dictionary(12) /'CHECK-DERI'/
      data dictionary(13) /'FEASIBILIT'/
      data dictionary(14) /'AVOID-LOSS'/
      data dictionary(15) /'OPTIMALITY'/
      data dictionary(16) /'MAX-INNER-'/
      data dictionary(17) /'MAX-FUNCTI'/
      data dictionary(18) /'OUTPUT-DET'/
      data dictionary(19) /'NCOMP-ARRA'/
      data dictionary(20) /'MLCOMP-ARR'/

      character * 38 description(nwords)
      data description( 1) /'ANALYTIC-GRADIENT                     '/
      data description( 2) /'FINITE-DIFFERENCES-GRADIENT           '/
      data description( 3) /'HESSIANS-PROVIDED                     '/
      data description( 4) /'LAGRHESS-PRODUCT-PROVIDED             '/
      data description( 5) /'INCREMENTAL-QUOTIENTS                 '/
      data description( 6) /'BFGS-QN-APPROXIMATION                 '/
      data description( 7) /'ADAPTIVE-HESSIAN                      '/
      data description( 8) /'GENCAN-BDSOLVER                       '/
      data description( 9) /'BETRA-BDSOLVER                        '/
      data description(10) /'UNPRECONDITIONED-CG                   '/
      data description(11) /'BFGS-QN-PRECONDITIONER                '/
      data description(12) /'CHECK-DERIVATIVES                     '/
      data description(13) /'FEASIBILITY-TOLERANCE                 '/
      data description(14) /'AVOID-LOSS-OF-FEASIBILITY             '/
      data description(15) /'OPTIMALITY-TOLERANCE                  '/
      data description(16) /'MAX-INNER-ITERATIONS                  '/
      data description(17) /'MAX-FUNCTION-EVALUATIONS              '/
      data description(18) /'OUTPUT-DETAIL                         '/
      data description(19) /'NCOMP-ARRAY                           '/
      data description(20) /'MLCOMP-ARRAY                          '/

      character * 1 addinfo(nwords)
      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) /' '/
      data addinfo(15) /'D'/
      data addinfo(16) /'I'/
      data addinfo(17) /'I'/
      data addinfo(18) /'I'/
      data addinfo(19) /'I'/
      data addinfo(20) /'I'/

C     LOCAL SCALARS
      integer i,ifirst,ikey,ilast,inum,j
      double precision dnum

C     LOCAL ARRAYS
      character * 80 line
      character * 10 keyword

C     OPENING THE SPECIFICATION FILE
      open(20,err=300,file='genlin.dat',status='old')

C     MAIN LOOP
      write(*, 9005)
      write(10,9005)

 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
          write(*, 9020) line(ifirst:ilast)
          write(10,9020) line(ifirst:ilast)
          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
              write(*, 9030) description(ikey)
              write(10,9030) description(ikey)
              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 ( 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

C     Set the corresponding genlin argument
      if ( ikey .eq. 1 ) then
          gtype = 0
      else if ( ikey .eq.  2 ) then
          gtype = 1
      else if ( ikey .eq.  3 ) then
          hptype = 0
      else if ( ikey .eq.  4 ) then
          hptype = 1
      else if ( ikey .eq.  5 ) then
          hptype = 3
      else if ( ikey .eq.  6 ) then
          hptype = 4
      else if ( ikey .eq.  7 ) then
          hptype = 6
      else if ( ikey .eq.  8 ) then
          intype  = 1
      else if ( ikey .eq.  9 ) then
          intype  = 2
      else if ( ikey .eq. 10 ) then
          precond = 'NONE'
      else if ( ikey .eq. 11 ) then
          precond = 'QNCGNA'
      else if ( ikey .eq. 12 ) then
          checkder = .true.
      else if ( ikey .eq. 13 ) then
          epsfeas = dnum
      else if ( ikey .eq. 14 ) then
          lossfeas = .false.
      else if ( ikey .eq. 15 ) then
          epsopt = dnum
      else if ( ikey .eq. 16 ) then
          maxtotit = inum
      else if ( ikey .eq. 17 ) then
          maxtotfc = inum
      else if ( ikey .eq. 18 ) then
          iprint = inum
      else if ( ikey .eq. 19 ) then
          ncomp = inum
      else if ( ikey .eq. 20 ) then
          mlcomp = 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
      write(*, 9000)
      write(10,9000)
      go to 500

C     ERROR READING THE SPECIFICATION FILE
 400  continue
      write(*, 9010)
      write(10,9010)
      go to 500

C     PRINTING PARAMETERS VALUES
 500  continue

      write(*, 4000) gtype,hptype,intype,precond,checkder,lossfeas,
     +epsfeas,epsopt,maxtotit,maxtotfc,iprint,ncomp,mlcomp

      write(10,4000) gtype,hptype,intype,precond,checkder,lossfeas,
     +epsfeas,epsopt,maxtotit,maxtotfc,iprint,ncomp,mlcomp

C     NON-EXECUTABLE STATEMENTS
 1000 format(A80)
 2000 format(BN,I20)
 3000 format(BN,F24.0)
 4000 format(/,' GENLIN PARAMETERS:',
     +       /,' gtype    = ',        I20,
     +       /,' hptype   = ',        I20,
     +       /,' intype   = ',        I20,
     +       /,' precond  = ',     14X,A6,
     +       /,' checkder = ',     19X,L1,
     +       /,' lossfeas = ',     19X,L1,
     +       /,' epsfeas  = ',8X,1P,D12.4,
     +       /,' epsopt   = ',8X,1P,D12.4,
     +       /,' maxtotit = ',        I20,
     +       /,' maxtotfc = ',        I20,
     +       /,' iprint   = ',        I20,
     +       /,' ncomp    = ',        I20,
     +       /,' mlcomp   = ',        I20)
 9000 format(/,' The optional specification file genlin.dat was not',
     +         ' found in the current',/,' directory (this is not a',
     +         ' problem nor an error). The default values for the',/,
     +         ' GENLIN parameters will be used.')
 9005 format(/,' Specification file genlin.dat is being used.')
 9010 format(/,' Error reading specification file genlin.dat.')
 9020 format(  ' Ignoring unknown keyword ',A32)
 9030 format(  ' Ignoring incomplete keyword ',A32)
 9040 format(1X,A32)
 9041 format(1X,A32,5X,I20)
 9042 format(1X,A32,1X,1P,D24.8)

      end

#ifndef CUTEr

C     *****************************************************************
C     *****************************************************************
      subroutine checkd(n,l,u,wd1,wd2,wd3,x,macheps,inform)

      implicit none

C     This subrotutine checks the user supplied first and second
C     derivatives subroutines (evalg and evalh) for computing the 
C     objective function gradient and Hessian, respectively.

C     SCALAR ARGUMENTS
      integer inform,n
      double precision macheps

C     ARRAY ARGUMENTS
      double precision l(n),u(n),wd1(n),wd2(n),wd3(n),x(n)

C     Parameters of the subroutine:
C     =============================
C
C     On Entry:
C     =========
C
C     N integer: Number of variables.
C     ---------
C
C     L double precision l(n): Lower bounds.
C     -----------------------
C
C     U double precision u(n): Upper bounds.
C     -----------------------
C
C     WD1 ... WD3, X double precision wd1(n) ... wd3(n), x(n) 
C     -------------------------------------------------------
C
C     N-dimensional double precision working vectors.
C
C     MACHEPS double precision
C     ------------------------
C
C     Smallest positive number such that 1 + macheps is not equal to 1.
C
C     On Return:
C     ==========
C
C     INFORM integer: Output flag.
C     --------------

C     LOCAL SCALARS
      character answer
      integer i
      double precision drand,seed,smalll,smallu

      inform = 0

C     SET A RANDOM POINT 

      seed = 17325.0d0
      do i = 1,n
          smalll = max( l(i), - 1.0d0 )
          smallu = min( u(i),   1.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(*,900)

      do i = 1,n
          write(*,910) i,x(i)
      end do

C     CHECK OBJECTIVE FUNCTION GRADIENT

      write(*,920)

      read(*,*) answer

      if ( answer .eq. 'A' .or. answer .eq. 'a' ) then
          go to 500

      else if ( answer .eq. 'Y' .or. answer .eq. 'y' ) then
          call checkg(n,x,wd1,macheps,inform)
          if ( inform .lt. 0 ) then
              return
          end if 
      end if

C     CHECK HESSIAN OF THE OBJECTIVE FUNCTION

      write(*,940)

      read(*,*) answer

      if ( answer .eq. 'A' .or. answer .eq. 'a' ) then
          go to 500

      else if ( answer .eq. 'Y' .or. answer .eq. 'y' ) then
          call checkh(n,x,wd1,wd2,wd3,macheps,inform)
          if ( inform .lt. 0 ) then
              return
          end if 
      end if

C     RETURN

 500  continue

      write(*,*) 'Hit any letter to continue.'
      read(*,*) answer

 900  format(/,1X,'Derivatives will be tested at the random point: ')
 910  format(  1X,'x(',I6,') = ',1P,D15.8)
 920  format(/,1X,'Check the gradient of the objective function?',
     +       /,1X,'Type Y(es), N(o) or A(bort checking): ')
 940  format(/,1X,'Check the Hessian matrix of the objective function?',
     +       /,1X,'Type Y(es), N(o) or A(bort checking): ')
      end

C     *****************************************************************
C     *****************************************************************
      subroutine checkg(n,x,g,macheps,inform)

      implicit none

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     SCALAR ARGUMENTS
      integer inform,n
      double precision macheps

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

C     Parameters of the subroutine:
C     =============================
C
C     On Entry:
C     =========
C
C     N integer: Number of variables.
C     ---------
C
C     X double precision x(n): Point at which the gradient will be tested.
C     -----------------------
C
C     G double precision g(n) 
C     -----------------------
C
C     N-dimensional double precision working vector.
C
C     MACHEPS double precision
C     ------------------------
C
C     Smallest positive number such that 1 + macheps is not equal to 1.
C
C     On Return:
C     ==========
C
C     INFORM integer: Output flag.
C     --------------

C     LOCAL SCALARS
      integer flag,i
      double precision fminus,fplus,gdiff1,gdiff2,maxerr,step1,step2,tmp

      inform = 0

      call evalg(n,x,g,flag)
      if ( flag .ne. 0 ) then
          inform = - 92
          return
      end if

      write(*,100)

      maxerr = 0.0d0

      do i = 1,n
          tmp  = x(i)

          step1 = macheps ** (1.0d0/3.0d0) * max( abs( tmp ), 1.0d0 )

          x(i) = tmp + step1
          call evalf(n,x,fplus,flag)
          if ( flag .ne. 0 ) then
              inform = - 90
              return
          end if

          x(i) = tmp - step1
          call evalf(n,x,fminus,flag)
          if ( flag .ne. 0 ) then
              inform = - 90
              return
          end if

          gdiff1 = ( fplus - fminus ) / ( 2.0d0 * step1 )

          step2 = macheps ** (1.0d0/3.0d0) * max( abs( tmp ), 1.0d-03 )

          x(i) = tmp + step2
          call evalf(n,x,fplus,flag)
          if ( flag .ne. 0 ) then
              inform = - 90
              return
          end if

          x(i) = tmp - step2
          call evalf(n,x,fminus,flag)
          if ( flag .ne. 0 ) then
              inform = - 90
              return
          end if

          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
          maxerr = max( maxerr, tmp )

      end do

      write(*,120) maxerr

      return

 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,g,gplus1,gplus2,macheps,inform)

      implicit none

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     SCALAR ARGUMENTS
      integer inform,n
      double precision macheps

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

C     Parameters of the subroutine:
C     =============================
C
C     On Entry:
C     =========
C
C     N integer: Number of variables.
C     ---------
C
C     X double precision x(n): Point at which the Hessian will be tested.
C     -----------------------
C
C     G, GPLUS1, GPLUS2 double precision g(n), gplus1(n), gplus2(n) 
C     -------------------------------------------------------------
C
C     N-dimensional double precision working vectors.
C
C     MACHEPS double precision
C     ------------------------
C
C     Smallest positive number such that 1 + macheps is not equal to 1.
C
C     On Return:
C     ==========
C
C     INFORM integer: Output flag.
C     --------------

C     PARAMETERS
      integer nsmax
      parameter ( nsmax      =    1000 )
      
C     LOCAL SCALARS
      logical nullcol
      integer flag,i,j,nnzh
      double precision elem,hdiff1,hdiff2,step1,step2,tmp

C     LOCAL ARRAYS
      integer hlin(nsmax**2),hcol(nsmax**2)
      double precision H(nsmax,nsmax),hval(nsmax**2),maxerr(nsmax)

      inform = 0

C     Test viability

      if ( n .gt. nsmax ) then
          write(*,*) 'Subroutine CheckH uses dense matrices up to ',
     +               'dimension ',nsmax,' times ',nsmax,'. The ',
     +               'Hessian checking will be skipped.'
          go to 500
      end if

C     Compute the gradient of the objective function at x

      call evalg(n,x,g,flag)
      if ( flag .ne. 0 ) then
          inform = - 92
          return
      end if

C     Compute the Hessian of the objective function at x and save in a
C     dense matrix

      call evalsh(n,x,hlin,hcol,hval,nnzh,flag)
      if ( flag .ne. 0 ) then
          inform = - 94
          return
      end if

      do j = 1,n
          do i = 1,n
              H(i,j) = 0.0d0
          end do
      end do

      do i = 1,nnzh
          H(hlin(i),hcol(i)) = H(hlin(i),hcol(i)) + hval(i)
      end do

C     Test column by column

      write(*,100)

      do j = 1,n

          tmp  = x(j)

          step1 = sqrt( macheps ) * max( abs( tmp ), 1.0d0 )

          x(j) = tmp + step1
          call evalg(n,x,gplus1,flag)
          if ( flag .ne. 0 ) then
              inform = - 92
              return
          end if

          step2 = sqrt( macheps ) * max( abs( tmp ), 1.0d-03 )

          x(j) = tmp + step2
          call evalg(n,x,gplus2,flag)
          if ( flag .ne. 0 ) then
              inform = - 92
              return
          end if

          x(j) = tmp

          write(*,105) j

          maxerr(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(*,106)
                  end if
                  write(*,110) i,elem,hdiff1,hdiff2,tmp
              end if
              maxerr(j) = max( maxerr(j), tmp )
          end do

          if ( nullcol ) then
              write(*,115)
          else
              write(*,120) maxerr(j)
          end if

      end do

      write(*,*)
      do j = 1,n
          write(*,130) j,maxerr(j)
      end do

 500  continue

      return

 100  format(/,1X,'Hessian matrix of the objective function column by ',
     +            'column.')
 105  format(/,1X,'Column:  ',I6)
 106  format(/,1X,'Index',13X,'evalh',3X,'Incr. Quoc. (two different ',
     +            'steps)',4X,'Absolute error')
 110  format(  1X,I5,4(3X,1P,D15.8))
 115  format(  1X,'All the elements of this column are null.')
 120  format(  1X,'Maximum absolute error = ',1P,D15.8)
 130  format(  1X,'Column ',I6,' Maximum absolute error = ',1P,D15.8)

      end
#endif

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

      subroutine evalobj(n,x,f,inform)

      implicit none

C     This subroutine computes the objective function.

C     SCALAR ARGUMENTS
      double precision f
      integer inform,n

C     ARRAY ARGUMENTS
      double precision x(n)

C     Parameters of the subroutine:
C     =============================
C
C     On Entry:
C     =========
C
C     N integer: Number of variables.
C     ---------
C
C     X double precision x(n): Current point.
C     -----------------------
C
C     On Return:
C     ==========
C
C     F double precision: Objective function value at x.
C     ------------------
C
C     INFORM integer
C     --------------
C
C     0 means that the evaluation was successfuly done.
C
C     Any other value means that some error occured during the 
C     evaluation.

C     LOCAL SCALARS
      integer flag

      inform = 0

C     COMPUTE OBJECTIVE FUNTION

      call evalf(n,x,f,flag)
      if ( flag .ne. 0 ) then
          inform = - 90
          return  
      end if

      end

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

      subroutine evalgr(n,x,g,gtype,macheps,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer gtype,inform,n
      double precision macheps

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

C     This subroutine computes the gradient of the objective function.


C     Parameters of the subroutine:
C     =============================
C
C     On Entry:
C     =========
C
C     N integer: Number of variables.
C     ---------
C
C     X double precision x(n): Current point.
C     -----------------------
C
C     GTYPE integer: 
C     -------------
C
C     0 if true gradient is to be used and 
C     1 if finite differences should be used.
C
C     MACHEPS double precision: Machine precision.
C     ------------------------
C
C     On Return:
C     ==========
C
C     G double precision g(n): 
C     --------------------------
C
C     Gradient of the objective function.
C
C     INFORM integer
C     --------------
C
C     0 means that the evaluation was successfuly done.
C
C     Any other value means that some error occured during the 
C     evaluation.

C     LOCAL SCALARS
      integer flag

      inform = 0

C     COMPUTE THE GRADIENT OF THE OBJECTIVE FUNCTION

      if ( gtype .eq. 0 ) then
          call evalg(n,x,g,flag)
          if ( flag .ne. 0 ) then
              inform = - 92
              return
          end if
      else
          call evalgdiff(n,x,g,macheps,inform)
          if ( inform .lt. 0 ) then
              return
          end if
      end if

      end

C     ******************************************************************
C     ******************************************************************
 
      subroutine evalhess(n,x,ldh,H,inform)

      implicit none

C     This subroutine might compute the Hessian matrix of the objective
C     function. For achieving this objective YOU MAY MODIFY it according 
C     to your problem. To modify this subroutine IS NOT MANDATORY. See 
C     below where your modifications must be inserted.
C     
C     Parameters of the subroutine:
C
C     On Entry
C
C     n        integer,
C              number of variables,
C
C     x        double precision x(n),
C              current point,
C
C     ldh      integer ldh,
C              leading dimension of matrix H,
C     
C     On Return
C
C     H        double precision H(ldh,n),
C              Hessian matrix of the objective function. Just the lower
C              triangular part of Hessian matrix must be computed,
C
C     inform   integer,
C              You must set it to any number different of 0 (zero) if 
C              some error ocurred during the evaluation of the Hessian
C              matrix of the objective function. (For example, trying 
C              to compute the square root of a negative number, 
C              dividing by zero or a very small number, etc.) If 
C              everything was o.k. you must set it equal to zero.

C     SCALAR ARGUMENTS
      integer inform,n,ldh

C     ARRAY ARGUMENTS
      double precision H(ldh,n),x(n)

C     LOCAL SCALARS
      integer flag

      inform = 0

      call evalh(n,x,ldh,H,flag)

      if (flag .ne. 0) then
         inform = - 94
         return
      end if
      
      end
      
C     *****************************************************************
C     *****************************************************************

      subroutine evalhessp(n,x,p,g,s,y,seucn,yeucn,sts,sty,lspgmi,
     +lspgma,samefa,gtype,hptype,aptype,hp,xp,macheps,inform,goth,hlspg,
     +hds,hstds)

      implicit none

C     SCALAR ARGUMENTS
      logical goth,samefa
      character * 6 aptype
      integer gtype,hptype,inform,n
      double precision hlspg,hstds,lspgma,lspgmi,macheps,seucn,sts,sty,
     +     yeucn
 
C     ARRAY ARGUMENTS
      double precision hds(n),hp(n),g(n),p(n),s(n),x(n),xp(n),y(n)

C     PARAMETERS
      integer hnnzmax
      parameter ( hnnzmax = 500000 )

C     COMMON SCALARS
      integer hlen

C     COMMON ARRAYS
      integer hcol(hnnzmax),hlin(hnnzmax)
      double precision hval(hnnzmax)

C     LOCAL SCALARS
      integer i,flag
      double precision c1,c2,psupn,ptds,pty,step,xsupn

C     COMMON BLOCK
      common /hessdata/ hval,hlin,hcol,hlen

      inform = 0

C     ==================================================================
C     HESSIAN APPROXIMATION TYPE
C     ==================================================================

C     True hessian-vector product using the user-provided second 
C     derivatives of the objective function and the constraints
      if ( hptype .eq. 0 ) then
          aptype = 'TRUEHE'

C     For user user-provided Hessian times vector subroutine
      else if ( hptype .eq. 1 ) then
          aptype = 'HLPROD'

C     Incremental quotients considering the non-differentiability of 
C     the Hessian matrix
      else if ( hptype .eq. 2 ) then
          aptype = 'INCQUO'

C     Idem 2
      else if ( hptype .eq. 3 ) then
          aptype = 'INCQUO'

C     Quasi-Newton correction of a Gauss-Newton approximation of the 
C     Hessian matrix
      else if ( hptype .eq. 4 ) then
          aptype = 'QNCGNA'

C     Idem 2
      else if ( hptype .eq. 5 ) then
          aptype = 'INCQUO'

C     Idem 2
      else if ( hptype .eq. 6 ) then
          aptype = 'INCQUO'

C     Incremental quotients without considering the non-differentiability 
C     of the Hessian matrix of the objective function
      else ! if ( hptype .eq. 9 ) then
          aptype = 'PUREIQ'
      end if

      if ( aptype .eq. 'TRUEHE' ) then
          go to 100
      else if ( aptype .eq. 'HLPROD' ) then
          go to 200
      else if ( aptype .eq. 'QNCGNA' ) then
          go to 300
      else if ( aptype .eq. 'INCQUO' ) then
          go to 400
      else ! if ( aptype .eq. 'PUREIQ' ) then
          go to 500
      end if

C     ==================================================================
C     EXACT SECOND-DERIVATIVES OF THE OBJECTIVE FUNCTION AND THE 
C     CONSTRAINTS WHERE PROVIDED BY THE USER. THE TRUE HESSIAN-VECTOR 
C     PRODUCT WILL BE COMPUTED
C     ==================================================================

 100  continue

C     ------------------------------------------------------------------
C     COMPUTE THE HESSIAN IF THIS IS THE FIRST TIME THIS SUBBROUTINE IS 
C     BEING CALLED
C     ------------------------------------------------------------------

      if ( .not. goth ) then
          goth = .true.

C         COMPUTE THE HESSIAN OF THE OBJECTIVE FUNCTION
          call evalsh(n,x,hlin,hcol,hval,hlen,flag)
          if ( flag .ne. 0 ) then
              inform = - 94
              return
          end if

      end if

C     ------------------------------------------------------------------
C     COMPUTE hp = \nabla^2 f(x) p
C     ------------------------------------------------------------------

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

      do i = 1,hlen
          if ( hlin(i) .ge. hcol(i) ) then
              hp(hlin(i)) = hp(hlin(i)) + hval(i) * p(hcol(i))
              if ( hlin(i) .ne. hcol(i) ) then
                  hp(hcol(i)) = hp(hcol(i)) + hval(i) * p(hlin(i))
              end if
          end if
      end do

      go to 900

C     ==================================================================
C     END OF USER-PROVIDED SECOND DERIVATIVES
C     ==================================================================

C     ==================================================================
C     A SUBROUTINE TO COMPUTE THE PRODUCT OF A VECTOR TIMES THE HESSIAN
C     OF THE OBJECTIVE WAS PROVIDED BY THE USER. THIS SUBROUTINE WILL
C     BE USED AND THEN THE FIRST-ORDER TERM WILL BE ADDED.
C     ==================================================================

 200  continue

C     ------------------------------------------------------------------
C     COMPUTE hp = ( \nabla^2 f(x) ) p
C     ------------------------------------------------------------------

      call evalhp(n,x,p,hp,goth,flag)
      if ( flag .ne. 0 ) then
          inform = - 96
          return
      end if

      go to 900

C     ==================================================================
C     END OF USER-PROVIDED HESSIAN X VECTOR PRODUCT
C     ==================================================================

C     ==================================================================
C     QUASI-NEWTON CORRECTION OF THE GAUSS-NEWTON APPROXIMATION OF THE 
C     HESSIAN MATRIX
C     ==================================================================

 300  continue

C     ------------------------------------------------------------------
C     COMPUTE THE QUASI-NEWTON CORRECTION OF THE GAUSS-NEWTON 
C     APPROXIMATION OF H IF THIS IS THE FIRST TIME THIS SUBBROUTINE IS 
C     BEING CALLED
C     ------------------------------------------------------------------

      if ( .not. goth ) then
          goth = .true.
          call comph(n,s,sts,sty,lspgmi,lspgma,hlspg,hds,hstds)
      end if

C     ------------------------------------------------------------------
C     COMPUTE THE STRUCTURED SPECTRAL CORRECTION S d, WHERE 
C     S = ( lamspg I ) AND lamspg = s^t (y - rho A^T A s) / (s^t s)
C     ------------------------------------------------------------------

C     hp = hlspg p

      do i = 1,n
          hp(i) = hlspg * p(i)
      end do

C     ------------------------------------------------------------------
C     ADD THE BFGS CORRECTION B p, WHERE
C     B = [ y y ^t / ( y^t s ) ] - [ D s ( D s )^t / ( s^t D s ) ], AND
C     D = hlspg I + rho A^T A
C     ------------------------------------------------------------------

C     hp = hp + B p = ( hlspg I + B ) p

      if ( samefa .and. sty .gt. 1.0d-08 * 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

      go to 900

C     ==================================================================
C     END OF GAUSS-NEWTON APPROXIMATION OF THE HESSIAN MATRIX
C     ==================================================================

C     ==================================================================
C     INCREMENTAL QUOTIENTS APPROXIMATION OF THE HESSIAN-VECTOR PRODUCT
C     TAKING CARE OF THE NON-DIFFERENTIABILITY
C     ==================================================================

 400  continue

C     COMPUTE INCREMENTAL QUOTIENTS STEP
      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 = sqrt( macheps ) * max( xsupn / psupn, 1.0d0 )

C     SET THE POINT AT WHICH THE GRADIENT OF THE OBJECTIVE FUNCTION WILL 
C     BE COMPUTED
      do i = 1,n
          xp(i) = x(i) + step * p(i)
      end do

C     COMPUTE THE GRADIENT OF THE OBJECTIVE FUNCTION AT xp
      if ( gtype .eq. 0 ) then
          call evalg(n,xp,hp,flag)
          if ( flag .ne. 0 ) then
              inform = - 92
              return
          end if
      else
          call evalgdiff(n,xp,hp,macheps,inform)
          if ( inform .lt. 0 ) then
              return
          end if
      end if

C     COMPUTE INCREMENTAL QUOTIENTS
      do i = 1,n
          hp(i) = ( hp(i) - g(i) ) / step
      end do 

      go to 900

C     ==================================================================
C     END OF INCREMENTAL QUOTIENTS APPROXIMATION OF THE HESSIAN-VECTOR 
C     PRODUCT TAKING CARE OF THE NON-DIFFERENTIABILITY
C     ==================================================================

C     ==================================================================
C     PURE INCREMENTAL QUOTIENTS APPROXIMATION OF THE HESSIAN-VECTOR 
C     PRODUCT (WITHOUT TAKING CARE OF THE NON-DIFFERENTIABILITY)
C     ==================================================================

 500  continue

C     COMPUTE INCREMENTAL QUOTIENTS STEP
      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 = sqrt( macheps ) * max( xsupn / psupn, 1.0d0 )

C     SET THE POINT AT WHICH THE GRADIENT OF THE OBJECTIVE FUNCTION
C     WILL BE COMPUTED
      do i = 1,n
          xp(i) = x(i) + step * p(i)
      end do

C     COMPUTE THE GRADIENT OF THE OBJECTIVE FUNCTION AT xp
      call evalgr(n,xp,hp,gtype,macheps,inform)
      if ( inform .lt. 0 ) then
          return
      end if

C     COMPUTE INCREMENTAL QUOTIENTS
      do i = 1,n
          hp(i) = ( hp(i) - g(i) ) / step
      end do 

      go to 900

C     ==================================================================
C     END OF PURE INCREMENTAL QUOTIENTS APPROXIMATION OF THE HESSIAN-
C     VECTOR PRODUCT (WITHOUT TAKING CARE OF THE NON-DIFFERENTIABILITY)
C     ==================================================================

 900  continue

      end

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

      subroutine comph(n,s,sts,sty,lspgmi,lspgma,hlspg,hds,hstds)

      implicit none

C     SCALAR ARGUMENTS
      integer n
      double precision lspgma,lspgmi,hlspg,hstds,sts,sty

C     ARRAY ARGUMENTS
      double precision hds(n),s(n)

C     Consider M the Hessian matrix of the objective function.
C
C     This subroutine computes an approximation H of matrix M following
C     a very simple idea: "discard the second order terms and then 
C     correct the remaining matrix in order to satisfy a secant 
C     equation".
C
C     Hence, H takes the form
C
C         H = hlspg I,
C
C     where
C
C     hlspg = max(lspgmi, min(lspgma, s^T y / s^T s))
C
C     Note that this subroutine does not compute matrix H explicitly,
C     but computes some quantities that will be used latter, by 
C     subroutine evalhd, to compute the product of H by a vector d.
C
C     The quantities computed by this subroutine are:
C
C     (a) hlspg = s^T y / (s^T s)
C
C     (b) hds = hlspg s, and
C
C     (c) hstds = <s,ds>.

C     LOCAL SCALARS
      integer i

C     ==================================================================
C     GAUSS-NEWTON CORRECTION OF THE HESSIAN MATRIX
C     ==================================================================

C     COMPUTE THE STRUCTURED SPECTRAL CORRECTION

C     ------------------------------------------------------------------
C     hlspg = (s^t y) / (s^t s)
C     ------------------------------------------------------------------

      if ( sty .le. 0.0d0 ) then
          hlspg = lspgmi
      else
          hlspg = max( lspgmi, min( sty / sts, lspgma ) )
      end if

      do i = 1,n
          hds(i) = hlspg * s(i)
      end do

      hstds = hlspg * sts

C     ==================================================================
C     END OF GAUSS-NEWTON APPROXIMATION OF THE HESSIAN MATRIX
C     ==================================================================

      end

C     *****************************************************************
C     *****************************************************************
      subroutine compp(n,s,y,seucn,yeucn,sts,sty,lspgmi,lspgma,samefa,
     +plspg,psmdy,psmdyty)

      implicit none

C     SCALAR ARGUMENTS
      logical samefa
      integer n
      double precision lspgma,lspgmi,plspg,psmdyty,seucn,sts,sty,yeucn

C     ARRAY ARGUMENTS
      double precision psmdy(n),s(n),y(n)

C     This subroutine computes:
C
C     (a) plspg such that E = plspg I, 
C
C     (b) psmdy = s - E^-1 y, and
C
C     (c) the inner product psmdty = <psmdy,y>.
C
C     These quantities will be used latter, in subroutine applyp, to
C     compute z = P^{-1} r.

C     LOCAL SCALARS
      integer i

C     ------------------------------------------------------------------
C     COMPUTE THE SPECTRAL CORRECTION E
C     ------------------------------------------------------------------

      if ( sty .le. 0.0d0 ) then
          plspg = lspgmi
      else
          plspg = max( lspgmi, min( sty / sts, lspgma ) )
      end if

C     ------------------------------------------------------------------
C     COMPUTE THE BFGS CORRECTION Q OF E
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
C     ------------------------------------------------------------------
 
      if ( samefa .and. sty .gt. 1.0d-08 * seucn * yeucn ) then

          psmdyty = 0.0d0
          do i = 1,n
              psmdy(i) = s(i) - y(i) / plspg 
              psmdyty = psmdyty + psmdy(i) * y(i)
          end do

      end if

      end

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

      subroutine evalgdiff(n,x,g,macheps,inform)

      implicit none

C     This subroutine approximates, by central finite differences, the 
C     gradient of the objective function.

C     SCALAR ARGUMENTS
      integer inform,n
      double precision macheps

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

C     Parameters of the subroutine:
C     =============================
C
C     On Entry:
C     =========
C
C     N integer: Number of variables.
C     ---------
C
C     X double precision x(n): Current point.
C     -----------------------
C
C     MACHEPS double precision: Machine epsilon.
C     ------------------------
C
C     On Return:
C     ==========
C
C     G double precision g(n): Gradient of the objective function.
C     -----------------------
C
C     INFORM integer
C     --------------
C
C     0 means that the evaluation was successfuly done.
C
C     Any other value means that some error occured during the 
C     evaluation.

C     LOCAL SCALARS
      integer flag,j
      double precision fminus,fplus,step,tmp

      do j = 1,n
          tmp  = x(j)

          step = macheps ** (1.0d0/3.0d0) * max( abs( tmp ), 1.0d0 )

          x(j) = tmp + step
          call evalf(n,x,fplus,flag)
          if ( flag .ne. 0 ) then
              inform = - 90
              return
          end if

          x(j) = tmp - step
          call evalf(n,x,fminus,flag)
          if ( flag .ne. 0 ) then
              inform = - 90
              return
          end if

          g(j) = ( fplus - fminus ) / ( 2.0d0 * step )
          x(j) = tmp
      end do

      end

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

      subroutine applyp(n,r,s,y,seucn,yeucn,sts,sty,lspgmi,lspgma,
     +samefa,gotp,pdiag,plspg,psmdy,psmdyty,z)

      implicit none

C     SCALAR ARGUMENTS
      logical gotp,samefa
      integer n
      double precision lspgma,lspgmi,plspg,psmdyty,seucn,sts,sty,yeucn

C     ARRAY ARGUMENTS
      double precision pdiag(n),psmdy(n),r(n),s(n),y(n),z(n)

C     Consider the preconditioner P.
C     Given the quantities computed in advance in the subroutine compp,
C     this subroutine computes z = P^{-1} r.

C     LOCAL SCALARS
      integer i
      double precision c1,c2,psmdytr,str

C     ------------------------------------------------------------------
C     COMPUTE P IF THIS IS THE FIRST TIME THIS SUBBROUTINE IS BEING 
C     CALLED
C     ------------------------------------------------------------------

      if ( .not. gotp ) then
          gotp = .true.
          call compp(n,s,y,seucn,yeucn,sts,sty,lspgmi,lspgma,samefa,
     +         plspg,psmdy,psmdyty)
      end if

C     ------------------------------------------------------------------
C     COMPUTE z = E^{-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
C
C     D = E
C     ------------------------------------------------------------------

      if ( samefa .and. sty .gt. 1.0d-08 * 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     =================================================================
C     Module: Linear-constraints solver GENLIN
C     =================================================================

C     Last update of any of the component of this module: 
C
C     May 1st, 2008.
      
      subroutine easygenlin(n,x,l,u,ml,mleq,lda,A,b,gtype,hptype,intype,
     +precond,epsgpsn,epscsn,lossfeas,maxit,maxfc,iprint,ncomp,mlcomp,
     +macheps,bignum,f,g,gpsupn,csupn,iter,fcnt,gcnt,hcnt,cgcnt,chcnt,
     +spgiter,spgfcnt,tniter,tnfcnt,triter,trfcnt,ispgiter,ispgfcnt,
     +iterql,inform,ldabar,Abar,ldh,H,wi1,wi2,wi3,wi4,wi5,wd1,wd2,wd3,
     +wd4,wd5,wd6,wd7,wd8,wd9,wd10,wd11,wd12,wd13,wd14,wd15,wd16,wd17,
     +wd18,wd19,wd20,wd21,wd22,wd23,lwd23)

      implicit none

C     SCALAR ARGUMENTS
      logical lossfeas
      character * 6 precond
      integer cgcnt,chcnt,fcnt,gcnt,hcnt,gtype,hptype,intype,ml,mleq,
     +        maxfc,maxit,n,ncomp,mlcomp,inform,iprint,iter,lda,ldabar,
     +        ldh,lwd23
      integer spgiter,spgfcnt,tniter,tnfcnt,triter,trfcnt,ispgiter,
     +        ispgfcnt,iterql
      double precision bignum,epsgpsn,epscsn,f,gpsupn,csupn,macheps

C     ARRAY ARGUMENTS
      integer wi1(n),wi2(n),wi3(ml),wi4(2*n+ml),wi5(n+ml)
      double precision g(n),l(n),u(n),wd1(n),wd2(n),wd3(n),wd4(n),
     +        wd5(n),wd6(n),wd7(n),wd8(n),wd9(n),wd10(n),wd11(n),
     +        wd12(n),wd13(n),wd14(n),wd15(n),wd16(n),wd17(n),wd18(n),
     +        wd19(n),wd20(n),wd21(ml),wd22(ml),wd23(lwd23),x(n),
     +        A(lda,n),Abar(ldabar,ml),H(ldh,n),b(ml)

C     This subroutine aims to simplify the use of GENLIN and BETRALIN. 
C     For this purpose it gives values to most of the GENLIN and 
c     BETRALIN arguments and leaves to the user those arguments which 
C     he/she may would like to set by him/herself.
C
C     The arguments of EASYGENLIN are the input and output arguments of 
C     GENLIN and BETRALIN that are supposed to be useful for a common 
C     user. The input arguments are mostly related to basic problem 
C     information, like dimension and bounds, and the initial point. 
C     There are also input arguments related to simple stopping criteria 
C     (like norm of the projected gradient, and maximum number of 
C     iterations and functional evaluations). There are also two input 
C     arguments related to control the amount of information written 
C     into the screen. The output arguments are related to information 
C     of the solution and some few performance measurements. Basically, 
C     on return, EASYGENLIN gives to the user the solution, the 
C     objective functional value and its gradient at the solution, 
C     Euclidian and sup-norm of the projected gradient at the solution, 
C     the number of iterations, functional, gradient and hessian 
C     evaluations, Conjugate Gradient and Cholesky decomposition 
C     iterations used to reach the solution, and, finally, a flag that 
C     indicates the stopping criterion that was satisfied.
C
C     All the other arguments of GENLIN and BETRALIN are setted with its
C     default values by EASYGENLIN. EASYGENLIN divides the arguments of 
C     GENLIN and BETRALIN in two sets. Those that are related to the 
C     behaviour of GENLIN and BETRALIN are declared as Fortran parameters 
C     (constants). The other arguments of GENLIN and BETRALIN, most of 
C     them related to alternative stopping criteria, and that may depend 
C     of, for example, maxit, are declared as local variables of 
C     EASYGENLIN.
C
C     GENLIN and BETRALIN arguments that are defined as Fortran parameters 
C     in this subroutine are GENLIN and BETRALIN arguments that should not 
C     be modified by a common user. They are arguments that modify the 
C     behaviour of GENLIN or BETRALIN and whose values were selected 
C     because they are classical values in some cases or because some 
C     numerical experiments seemed to indicate that they are the best 
C     choices.
C
C     GENLIN and BETRALIN arguments that are declared as local variables 
C     in this subroutine are GENLIN and BETRALIN arguments that may be 
C     modified if, with their suggested values, GENLIN and BETRALIN do 
C     not give the desired result. Most of them are related to Conjugate 
C     Gradients or to disabled stopping criteria that may be useful 
C     in bad-scaled problems or problems with not trustable derivatives.
C
C     Finally, this subroutine declares as local variables some 
C     arguments of GENLIN and BETRALIN which in fact are output 
C     arguments. Most of them are related to quantities that can be used 
C     for statistics related to the GENLIN or BETRALIN performance, like 
C     number Interpolation steps, etc. As we assume that this values are 
C     not useful for the common user, this subroutine throw all of them 
C     away.
C
C     We describe below the meaning of the arguments of the EASYGENLIN
C     subroutine. More detailed descriptions as well as the descriptions 
C     of all the other GENLIN and BETRALIN arguments that are not 
C     arguments of EASYGENLIN are also described at the begining of the 
C     GENLIN and BETRALIN subroutines.
C     
C     Parameters of the subroutine:
C
C     On entry:
C
C     n        integer 
C              number of variables
C
C     x        double precision x(n)
C              initial estimation of the solution
C
C     l        double precision l(n)
C              lower bounds on the variables
C
C     u        double precision u(n)
C              upper bounds on the variables
C
C     ml       integer
C              total number of linear constraints (excluding bounds)
C
C     mleq     integer
C              number of linear equality constraints (excluding bounds)     
C      
C     lda      integer
C              leading dimension of matrix A
C      
C     A        double precision A(lda,n)
C              coeficients of linear constraints
C
C     b        double precision b(ml)
C              constant part of linear constraints
C
C     gtype    integer,
C              type of derivatives calculation according to the 
C              following convention:
C
C              = 0, true derivatives. In this case, subroutines evalg
C                   and evaljac must be modified by the user to compute
C                   the derivatives of the objective function and the
C                   constraints.
C              = 1, finite differences approximation provided by 
C                   GENLIN. In this case, subroutines evalg and 
C                   evaljac may have an empty body but must be present.
C                   It is also recommended that those empty-body
C                   subroutines set flag = - 1. Last but not least,
C                   the option gtype = 1 is not cheap neither safe.
C
C     hptype   integer
C              The way in which the product of the Hessian matrix
C              by a vector will be done 
C              depends on the value of the parameter hptype in the 
C              following way:
C
C              = 0, means that the subroutine to compute the Hessian of 
C                   the objective function (evalh) was provided by the 
C                   user. So, the product of the Hessian times a vector 
C                   will be computed using the Hessian provided by this 
C                   subroutine.
C
C              = 9, means that an incremental quotients approximation 
C                   will be used. This option requires the evaluation of 
C                   an extra gradient at each Conjugate Gradient 
C                   iteration. If gtype = 0 then this gradient evaluation 
C                   will be done using the user supplied subroutine 
C                   evalg. On the other hand, if gtype = 1, the gradient 
C                   calculation will be done using just calls to the user 
C                   provided subroutine evalf. nind calls will be done, 
C                   where nind is the dimension of the current face of 
C                   the active-set method.
C
C              Options hptype = 2 and hptype = 3 are both identical to 
C              hptype = 9.
C
C              If you did not code subroutine evalg to compute the 
C              gradient of the objective function then your options 
C              finished here.
C
C              = 4, means that the Hessian matrix will be approximated
C                   and then the product of the Hessian approximation
C                   by the vector will be computed exactly. The 
C                   approximation is a BFGS approximation of the 
C                   Hessian (without memory) and using the spectral
C                   approximation (instead of the identity) as initial
C                   approximation.
C
C                   Numerical experiments suggested that this option is
C                   not convenient for unconstrained or just bound-
C                   constrained problems. (Note that this option was
C                   developed to be used in the Augmented Lagrangian
C                   framework.)
C
C                   This option does NOT require an extra gradient
C                   evaluation per iteration and, in this sense, each
C                   CG iteration is computationally cheaper than a CG
C                   iteration of the previous choices.
C
C                   Quadratic subproblems are convex with this choice.
C
C              Options hptype = 5 and hptype = 6 are both identical to 
C              hptype = 9.
C
C     intype   integer
C              decide which inner algorithm should be used to solve 
C              linearly-constrained subproblems:
C
C              = 1 means GENLIN is used.
C
C              = 2 means dense version of BETRALIN is used.
C
C     precond  character * 6
C              indicates the type of preconditioning that will be used
C              for Conjugates Gradients.
C
C              'NONE'   means no preconditioner at all,
C
C              'QNCGNA' means Quasi-Newton Correction of the Gauss-
C                       Newton approximation of the Hessian. The exact
C                       form is this preconditioner is described in:
C 
C                       E. G. Birgin and J. M. Martínez, "Structured 
C                       minimal-memory inexact quasi-Newton method and 
C                       secant preconditioners for Augmented Lagrangian 
C                       Optimization", Computational Optimization and 
C                       Applications, 39, pp, 1-16, 2008.
C
C     epsgpsn  double precision
C              GENLIN or BETRALIN stop declaring convergence if it finds 
C              a point whos projected gradient sup-norm is smaller than
C              or equal to epsgpsn
C
C     epscsn   double precision
C              feasibility tolerance for the sup-norm of the linear
C              constraints
C     
C     lossfeas logical
C              if a loss of feasibility up to sqrt(epsfeas) is allowed
C              during the computations, lossfeas must be set to TRUE
C              (recommended). In this case, if the final iterate does
C              not satisfy the constraints with the desired precision,
C              we sugest that the user re-run the method using the final
C              point obtained as the initial point, using
C              lossfeas = FALSE
C
C     maxit    integer
C              GENLIN or BETRALIN stops declaring ''maximum number of 
C              iteration achieved'' if the number of iterations exceeds 
C              maxit
C
C     maxfc    integer
C              the same as before but with the number of functional 
C              evaluations
C
C     iprint   integer
C              indicates the degree of details of the output generated 
C              by GENLIN or BETRALIN. Setting iprint to a value smaller 
C              than 2 will make GENLIN or BETRALIN to generate no output 
C              at all. An iprint value greater than or equal to 2 will 
C              generate information of every GENLIN and BETRALIN iteration. 
C              An iprint value greater than or equal to 3 will also show 
C              information of the Conjugate Gradient iterations (used to 
C              compute the Truncated Newton direction) or trust region
C              iterations and also information related to the line 
C              search procedures in the Spectral Projected Gradient
C              direction and the Truncated Newton direction.
C
C     ncomp    integer,         
C              every time a vector is printed, just its first ncomp
C              component will be displayed.
C
C     mlcomp   integer,         
C              every time a linear constrait is printed, just its first 
C              mlcomp component will be displayed.
C
C     macheps  double precision
C              macheps is the smallest positive number such that
C              1 + macheps is not equal to 1
C
C     bignum   double precision
C              a big number like 1.0d+99
C
C     ldabar,ldh integer
C              leading dimension of matrices Abar and H
C
C     Abar,H   double precision Abar(ldabar,ml),H(ldh,n)
C              working matrix
C     
C     wi1,wi2  integer wi1,wi2(n)
C              n-dimensional working vectors of integers
C
C     wi3      integer wi3(ml),
C     wi4      integer wi4(2*n+ml)
C     wi5      integer wi5(n+ml)
C              integer working vectors
C
C     wd1, ..., wd20 double precision wd1(n), ..., wd20(n)
C              n-dimensional working vectors of doubles
C
C     wd21,wd22 double precision wd21,wd22(ml)
C              double precision working vectors
C
C     wd23     double precision wd23(lwd23)
C              double precision working vector
C
C     On return:
C
C     x        double precision x(n)
C              estimation of the solution
C
C     f        double precision
C              objective function value at the solution
C
C     g        double precision g(n)
C              gradient of the objective function at the solution
C
C     gpsupn   double precision
C              sup-norm of the discontinuous projected gradient
C
C     csupn    double precision
C              sup-norm of the linear constraints
C
C     iter     integer
C              number of iterations used to reach the solution
C
C     fcnt     integer
C              number of functional evaluations
C
C     gcnt     integer
C              number of gradient evaluations
C
C     hcnt     integer
C              number of hessian evaluations
C
C     cgcnt    integer
C              number of Conjugate Gradient iterations
C
C     chcnt    integer
C              number of Cholesky decompositions
C
C     spgiter  integer
C              number of PSPG iterations
C
C     spgfcnt  integer
C              number of functional evaluations performed in PSPG 
C              iterations
C
C     tniter   integer
C              number of Truncated-Newton iterations
C
C     tnfcnt   integer
C              number of functional evaluations performed in  
C              Truncated-Newton iterations
C
C     triter   integer
C              number of Trust-region iterations
C
C     trfcnt   integer
C              number of functional evaluations performed in
C              Trust-region iterations
C
C     ispgiter integer
C              number of inner SPG iterations
C
C     ispgfcnt integer
C              number of functional evaluations performed in inner 
C              SPG iterations
C
C     iterql   integer
C              number of calls to QL routine (used to perform 
C              projections)
C
C     inform   integer
C              termination criteria. inform equal to 0 means that 
C              GENLIN (BETRALIN) converged with the sup-norm of the
C              dicontinuous projected gradient stopping criterion. Other 
C              positive values means that GENLIN or BETRALIN stopped by 
C              a maybe not successful stopping criteria. A negative 
C              value means that there was an error in the user-defined 
C              subroutines that computes the objective function 
C              (subroutine evalobj), the gradient (subroutine evalgr), 
C              the Hessian-vector product (subroutine evalhd), or in the
C              projection routine.
C
C              The values of inform mean:
C 
C              0 = convergence with small sup-norm of the continuous 
C                  projected gradient (smaller than epsgpsn);
C
C              2 = the algorithm stopped by ''lack of progress'', that 
C                  means that f(xk) - f(x_{k+1}) <= epsnfp * 
C                  max{ f(x_j) - f(x_{j+1}, j < k } during maxitnfp 
C                  consecutive iterations. If desired, set maxitnfp 
C                  equal to maxit to inhibit this stopping criterion.
C
C              4 = the algorithm stopped because the functional value 
C                  is very small (smaller than fmin). If desired, set 
C                  fmin equal to minus bignum to inhibit this stopping 
C                  criterion.
C
C              5 = the algorithm stopped because the trust-region radius 
C                  is very small (smaller than macheps**(2.0d0/3.0d0)).
C
C              6 = too small step in a line search. After having made at 
C                  least mininterp interpolations, the steplength 
C                  becames small. ''small steplength'' means that we are 
C                  at point x with direction d and step alpha, such that
C
C                  | alpha * d(i) | <= macheps * max( | x(i) |, 1 ) 
C
C                  for all i.
C
C                  In that case failure of the line search is declared 
C                  (may be the direction is not a descent direction due 
C                  to an error in the gradient calculations). If 
C                  desired, set mininterp equal to maxfc to inhibit this 
C                  stopping criterion.
C
C              7 = it was achieved the maximum allowed number of 
C                  iterations (maxit).
C
C              8 = it was achieved the maximum allowed number of 
C                  function evaluations (maxfc).
C
C              9 = the algorithm stopped because the function provided by 
C                  the user to decide whether or not the algorithm should
C                  stop at the current iteration returned a true value.
C
C             10 = the algorithm stopped because a direction could not be
C                  computed because of errors occured during its
C                  calculations.
C
C            -30 = the algorithm stopped in a feasible point because a 
C                  problem occured in projection subroutine. Probably, we 
C                  are asking for too much accuracy in projection;
C
C            -40 = the algorithm stopped because the point infeasible. 
C                  Probably, we are asking for little accuracy in
C                  projection;
C
C            -50 = error in QR decomposition;
C      
C            -70 = some linear constraints are inconsistent;
C
C            -90 = means that subroutine evalf retuned an error flag;
C
C            -92 = means that subroutine evalg retuned an error flag;
C
C            -94 = means that subroutine evalh retuned an error flag;
C 
C     HERE STARTS THE DESCRIPTION OF SOME GENLIN ARGUMENTS THAT ARE 
C     BEING SETTED INSIDE EASYGENLIN. THE FIRST SET OF ARGUMENTS ARE 
C     THOSE ARGUMENTS THAT WE WILL CALL ''CONSTANTS'' AND THAT, AS THEIR 
C     VALUES ALTER THE BEHAVIOUR OF GENLIN, SHOULD NOT BE MODIFIED BY A 
C     COMMON USER.

C     CONSTANTS FOR CLASSICAL LINE-SEARCH CONDITIONS (PSPG AND GENCAN)

C     gamma is the constant for the sufficient decrease ''Armijo 
C     condition''.

C     theta is the constant for the ''angle condition''.

C     sigma1 and sigma2 are the constants for the safeguarding quadratic 
C     interpolations. We use them in a rather unusual way. Instead of 
C     discarding a new step anew if it does not belong to the interval 
C     [ sigma1 * aprev, sigma2 * aprev ], we discard it if it does not 
C     belong to the interval [ sigma1, sigma2 * aprev ]. In such a case 
C     we take something similar to ''anew = aprev / 2''.

      double precision gamma,theta,sigma1,sigma2
      parameter ( gamma  = 1.0d-04 )
      parameter ( theta  = 1.0d-06 )
      parameter ( sigma1 =   0.1d0 )
      parameter ( sigma2 =   0.9d0 )

C     CONSTANTS FOR CLASSICAL TRUST-REGION CONDITIONS (WFBETRA)

C     alpha id the constant for the sufficient decrease , when comparing 
C     the predicted decrease of funcional value (given by the quadratic 
C     model) and the real one.

      double precision alpha
      parameter (alpha   =   0.1d0 )

C     CONSTANTS FOR SPECIFIC PROCEDURES (NOT SO CLASSICAL)

C     In line searches, when interpolating, the step may become so 
C     small that we should declare a line search failure indicating that 
C     direction may not be a descent direction. This decision is never 
C     take before doing at least mininterp interpolations.

C     In the line searches, when we need to interpolate and the result 
C     of the quadratic interpolation is rejected, the new step is 
C     computed as anew = aprev / etaint. 

C     When computing the Newton direction by Conjugate Gradients we 
C     never go further an artificial ''trust region''. This ''trust 
C     radius'' is never smaller than delmin.

C     We always use as a first step in a line search procedure along a
C     first order direction the spectral steplength. This steplength 
C     must belong to the interval [lspgmi,lspgma].

C     When computing the direction using More-Sorensen's algorithm, the
C     successfull stopping criteria involve mseps. It can also stop 
C     because it exceeded the maximum allowed number of iterations 
C     msmaxit. mssig is a tolerance of how far from the boundary of the 
C     trust-region a direction (that should be on the boundary) may be.
C     msrho is used to garantee that a certain direction to be computed
C     will be inside the feasible region.

C     phieps is used to decide if a point is minimizer of the quadratic 
C     model (WFBETRA). msrho is used to shrink the trust region radius so
C     the next direction is inside the region defined by the constraints.

      integer mininterp
      parameter ( mininterp =   4 )

      double precision etaint,delmin,lspgma,lspgmi
      parameter ( etaint  =   2.0d0 )
      parameter ( delmin  = 1.0d+04 )
      parameter ( lspgma  = 1.0d+10 )
      parameter ( lspgmi  = 1.0d-10 )

      integer msmaxit
      parameter ( msmaxit =      20 )

      double precision mseps, mssig, phieps, msrho
      parameter ( mseps   = 1.0d-08 )    
      parameter ( mssig   = 0.1d+00 )
      parameter ( phieps  = 1.0d-05 )
      parameter ( msrho   = 0.7d+00 )
      
C     HERE STARTS THE DESCRIPTION OF THE OTHER ARGUMENTS OF GENLIN BEING 
C     SETTED BY EASYGENLIN. THESE ARGUMENTS MAY BE MODIFIED BY A COMMON 
C     USER IF, WITH THEIR SUGGESTED VALUES, GENLIN DOES NOT GIVE THE 
C     EXPECTED RESULT.

C     GENLIN AND BETRALIN INPUT ARGUMENTS THAT WILL BE SETTED BELOW

      integer cgscre,maxitnfp,maxitnqmp,trtype,ktest
      double precision cgepsf,cgepsi,cggpnf,cgmia,cgmib,delta0,epsnfp,
     +epsnqmp,fmin,trdelini,trdelmin

C     GENLIN ANS BETRALIN OUTPUT ARGUMENTS THAT WILL BE DISCARDED

      integer tnintcnt,tnintfe,tnstpcnt,promaxit
      double precision gpeucn2,projeps,toldgp

C     ARGUMENTS RELATED TO STOPPING CRITERIA (GENLIN AND BETRALIN)

C     maxitnfp means MAXimum of allowed number of iterations with No 
C     Progress in the objective functional value. ''Progress'' from one 
C     iteration to the next one refers to ( fnew - fprev ). Since the 
C     begining of the algorithm we save the ''best progress'' and 
C     consider that there was no progress in an iteration if the 
C     progress of this iterations was smaller than epsnfp times the best 
C     progress. Finally, the algorithm stops if there was no progress 
C     during maxitnfp consecutive iterations.

      maxitnfp  =       50
      epsnfp    =  macheps

C     There is a stopping criterion that stops the method if a point 
C     with a functional value smaller than fmin is found. The idea 
C     behind this stopping criterion is to stop the method if the 
C     objective function is not bounded from bellow.

      fmin      = - 1.0d+20

C     ARGUMENTS RELATED TO CONJUGATE GRADIENTS (GENCAN)

C     When computing the Truncated Newton direction by Conjugate 
C     Gradients there is something similar to a ''trust-region radius''. 
C     This trust radius is updated from iteration to iteration depending 
C     on the agreement of the objective function and its quadratic 
C     model. But an initial value for the trust radius is required. If 
C     the user has a good guess for this initial value then it should be 
C     passed to WFGENCAN using the delta0 arguments. On the other hand, 
C     if delta0 is set to -1, a default value depending on the norm of 
C     the current point will be used.

      delta0    =  - 1.0d0

C     The ''trust-region'' can be like a ball (using Euclidian norm) or 
C     like a box (using sup-norm). This choice can be made using trtype 
C     (TRust region TYPE) argument. trtype equal to 0 means Euclidian 
C     norm and trtype equal to 1 means sup-norm.

      trtype    =        0

C     When the method is far from the solution, it may be not useful to 
C     do a very large effort in computing the Truncated Newton direction 
C     precisely. To avoid it, a fixed maximum number of iterations for 
C     Conjugate Gradients can be given to WFGENCAN. If the user would like 
C     to choose this maximum number of iterations for Conjugate 
C     Gradient then it should use cgmia and cgmib arguments. On the other 
C     hand, if he/she prefers to leave this task to WFGENCAN then he/she 
C     should set cgmia = -1.0d0 and cgmib = -1.0d0.
 
      cgmia     =  - 1.0d0
      cgmib     =  - 1.0d0

C     If the task of deciding the accuracy for computing the Truncated 
C     Newton direction is leaved to WFGENCAN then a default strategy based 
C     on increasing accuracies will be used. The proximity to the 
C     solution is estimated observing the norm of the projected gradient 
C     at the current point and locating it between that norm at the 
C     initial point and the expected value of that norm at the solution. 
C     Then the accuracy for the Truncated Newton direction of the 
C     current iteration will be computed taking a precision located in 
C     the same relative position with respect to two given values for 
C     the accuracies for the first and the last Truncated Newton 
C     direction calculations. These two accuracies (cgepsi and cgepsf, 
C     respectively) must be given by the user. Moreover, the expected 
C     value of the projected gradient norm at the solution (cggpnf) must
C     also be given by the user who must indicate setting argument 
C     cgscre to 1 or 2 if that norm is the Euclidian or the sup-norm.
      
      cggpnf    =  max( 1.0d-04, epsgpsn )
      cgscre    =        2
      cgepsi    =  1.0d-01
      cgepsf    =  1.0d-08

C     The next two arguments are used for an alternative stopping 
C     criterion for Conjugate Gradients. Conjugate Gradients method is 
C     stopped if the quadratic model makes no progress during maxitnqmp 
C     (MAXimum of ITerations with No Quadratic Model Progress) 
C     consecutive iterations. In this context, ''no progress'' means 
C     that the progress is smaller than epsnqmp (EPSilon to measure the 
C     No Quadratic Model Progress) times the best progress obtained 
C     during the previous iterations.

      epsnqmp   =  1.0d-08
      maxitnqmp =        5

C     ARGUMENTS RELATED TO TRUST-REGION RADIUS (WFBETRA)

C     At each iteration, the trust-region radius must be greater then 
C     trdelmin. This parameter is also used to decide if and trust-region 
C     iteration or an inner spg iteration will be used inside a face.
C     trdelini is used to calculate the initial trust-region radius, that 
C     will be greater or equal to trdelini.

      trdelini  =  1.0d+02
      trdelmin  =  1.0d-08

C     ARGUMENT RELATED WHEN CALCULATE PROJECTED GRADIENT

C     Since projection is expensive, the projected gradient is computed 
C     only when ktest consecutive iterations made the number of 
C     constraits in the active set bigger, or when it is necessary.
      
      ktest   =     20

C     SET PROJECTION PARAMETERS

      projeps   = epscsn**1.25d0
      promaxit  =           5000

      toldgp    =          0.1d0

C     FINALLY, CALL GENLIN

      call genlin(n,x,l,u,ml,mleq,lda,A,b,gtype,hptype,intype,precond,
     +epsgpsn,maxitnfp,epsnfp,fmin,maxit,maxfc,delta0,cgmia,cgmib,
     +cgscre,cggpnf,cgepsi,cgepsf,epsnqmp,maxitnqmp,etaint,mininterp,
     +trtype,iprint,ncomp,mlcomp,macheps,bignum,f,g,gpeucn2,gpsupn,
     +csupn,epscsn,lossfeas,iter,fcnt,gcnt,hcnt,cgcnt,chcnt,spgiter,
     +spgfcnt,ispgiter,ispgfcnt,tniter,tnfcnt,tnstpcnt,tnintcnt,tnintfe,
     +triter,trfcnt,iterql,inform,wd1,wd2,wd3,wd4,wd5,wi1,wi2,wi3,wd6,
     +wd7,wd8,wd9,wd10,wd11,wd12,wd13,wd14,wd15,wd16,wd17,wd18,wd23,
     +lwd23,wd21,wd19,wd20,ldabar,Abar,wd22,ldh,H,wi4,wi5,delmin,
     +lspgma,lspgmi,theta,gamma,sigma1,sigma2,msmaxit,msrho,mseps,
     +phieps,mssig,trdelini,trdelmin,alpha,projeps,promaxit,ktest,
     +toldgp)

      end

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

      subroutine genlin(n,x,l,u,ml,mleq,lda,A,b,gtype,hptype,intype,
     +precond,epsgpsn,maxitnfp,epsnfp,fmin,maxit,maxfc,udelta0,ucgmia,
     +ucgmib,cgscre,cggpnf,cgepsi,cgepsf,epsnqmp,maxitnqmp,etaint,
     +mininterp,trtype,iprint,ncomp,mlcomp,macheps,bignum,f,g,gpeucn2,
     +gpsupn,csupn,epscsn,lossfeas,iter,fcnt,gcnt,hcnt,cgcnt,chcnt,
     +spgiter,spgfcnt,ispgiter,ispgfcnt,tniter,tnfcnt,tnstpcnt,tnintcnt,
     +tnintfe,triter,trfcnt,iterql,inform,s,y,d,xprev,gprev,ind,ind2,
     +iact,wd1,wd2,wd3,wd4,wd5,wd6,wd7,wd8,wd9,wd10,wd11,wd12,wd13,wd14,
     +lwd14,wd15,gz,dz,ldabar,Abar,tau,ldh,H,wi1,rbdind,delmin,lspgma,
     +lspgmi,theta,gamma,sigma1,sigma2,msmaxit,msrho,mseps,phieps,mssig,
     +trdelini,trdelmin,alpha,projeps,promaxit,ktest,toldgp)

      implicit none

C     SCALAR ARGUMENTS
      logical lossfeas
      character * 6 precond
      integer cgcnt,chcnt,cgscre,fcnt,gcnt,hcnt,gtype,hptype,intype,
     +        inform,iprint,iter,ml,mleq,lda,maxfc,maxit,maxitnfp,
     +        maxitnqmp,mininterp,n,ncomp,mlcomp,spgfcnt,spgiter,
     +        ispgfcnt,ispgiter,tnfcnt,tnintcnt,tnintfe,tniter,tnstpcnt,
     +        triter,trfcnt,iterql,trtype,ldabar,ldh,lwd14,msmaxit,
     +        promaxit,ktest
      double precision bignum,cgepsf,cgepsi,cggpnf,delmin,epsgpsn,
     +        epsnfp,epsnqmp,etaint,f,fmin,gamma,gpeucn2,gpsupn,csupn,
     +        lspgma,lspgmi,macheps,sigma1,sigma2,theta,ucgmia,ucgmib,
     +        udelta0,msrho,mseps,phieps,mssig,trdelini,trdelmin,alpha,
     +        epscsn,projeps,toldgp

C     ARRAY ARGUMENTS
      integer ind(n),ind2(n),iact(ml),wi1(2*n+ml),rbdind(n+ml)
      double precision d(n),g(n),gprev(n),l(n),s(n),u(n),wd1(n),wd2(n),
     +        wd3(n),wd4(n),wd5(n),wd6(n),wd7(n),wd8(n),wd9(n),wd10(n),
     +        wd11(n),wd12(n),wd13(n),wd14(lwd14),wd15(ml),gz(n),dz(n),
     +        x(n),xprev(n),y(n),H(ldh,n),A(lda,n),b(ml),
     +        Abar(ldabar,ml),tau(ml)

C     Solves the linearly-constrained minimization problem
C
C                         Minimize f(x)
C
C                         subject to 
C   
C                               Aix  = bi, i = 1, mleq
C                               Cix >= di, i = mleq+1, ml
C                                 l <= x <= u
C
C     using a method described in 
C
C     M. Andretta, E. G. Birgin and J. M. Martinez, ''Partial Spectral 
C     Projected Gradient Method with Active-Set Strategy for Linearly
C     Constrained Optimization'', Submitted, 2008.

C     DATA BLOCKS
      character * 41 ittext(8)
      data ittext(1) /'(Used a PSPG iteration)                  '/
      data ittext(2) /'(Used TN with the ANALYTIC HESSIAN)      '/
      data ittext(3) /'(Used TN with the USER HP PRODUCT)       '/
      data ittext(4) /'(Used TN with a QN HESSIAN APPROX)       '/
      data ittext(5) /'(Used TN with INCREMENTAL QUOTIENTS)     '/
      data ittext(6) /'(Used TN with PURE INCREMENTAL QUOTIENTS)'/
      data ittext(7) /'(Used a inner SPG iteration)             '/
      data ittext(8) /'(Used a trust-region iteration)          '/

C     LOCAL SCALARS
      logical samefa,gencan,calcAx,frst,gotgp,gotgpp,gotd,changed
      character * 6 precondd
      integer fcntprev,infotmp,ittype,itnfpin,itnfpspg,nind,nind2,
     +        nprint,cgcntprev,chcntprev,triterprev,informprev,mlprint,
     +        index1,index2,i,ii,j,jj,k,nact,nliact,rbdlu,rbdli,tolact,
     +        hitbd,intnan
      double precision bestprog,acgeps,bcgeps,currprog,fprev,lamspg,
     +        seucn,ssupn,sts,sty,yeucn,xeucn2,xsupn,mslamb,trdelta,
     +        stlen,newtrdelta,gzsupn,px,seed,maxstp,tmp,ax,ad,sgpsupn,
     +        gsupn,toldgptmp

C     FUNCTIONS
      double precision drand

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

C     Set some initial values:

C     just for printing,
      nprint   = min0(  n,  ncomp )
      mlprint  = min0( ml, mlcomp )
 
C     for testing progress in f and decrease of the sup-norm of the 
C     internal gradient,
      fprev      = bignum
      bestprog   =  0.0d0
      itnfpin    =      0
      itnfpspg   =      0

C     to sum something to initial point when f(x) or g(x) is NAN
      frst       = .true.
      seed       = 1234567.0d0

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

C     for calculating matrix-vector product A x, and
      calcAx     = .true.

      intnan     =  0
      toldgptmp  = toldgp

C     for choosing the algorithm to be used within the faces,
      cgcntprev  =  0
      chcntprev  =  0
      triterprev =  0
      informprev =  0

C     counters.
      iter       =  0
      fcnt       =  0
      gcnt       =  0
      hcnt       =  0
      chcnt      =  0
      cgcnt      =  0

      spgiter    =  0
      spgfcnt    =  0

      ispgiter   =  0
      ispgfcnt   =  0

      triter     =  0
      trfcnt     =  0

      tniter     =  0
      tnfcnt     =  0

      tnstpcnt   =  0
      tnintcnt   =  0

      tnintfe    =  0

      hitbd      =  0

      iterql     =  0

C     Print problem information

      if( iprint .ge. 2 ) then
          write(*, 973) n
          write(*, 974) ml
          write(*, 975) mlprint
          do i = 1,mlprint
              write(*, 976) nprint, (A(i,j), j = 1, nprint)
          end do
          write(*, 977) mlprint,(b(i),i=1,mlprint)
          write(*, 978) nprint, (l(i),i=1,nprint)
          write(*, 979) nprint, (u(i),i=1,nprint)
          write(*, 980) nprint, (x(i),i=1,nprint)

          write(10,973) n
          write(10,974) ml
          write(10,975) mlprint
          do i = 1,mlprint
              write(10,976) nprint, (A(i,j), j = 1, nprint)
          end do
          write(10,977) mlprint,(b(i),i=1,mlprint)
          write(10,978) nprint, (l(i),i=1,nprint)
          write(10,979) nprint, (u(i),i=1,nprint)
          write(10,980) nprint, (x(i),i=1,nprint)
      end if

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

 600  continue

      iter = 1

      call project(n, x, l, u, ml, mleq, lda, A, b, promaxit, projeps, 
     +     .false., epscsn, csupn, macheps, wi1, wd3, wd14, lwd14, wd4, 
     +     iterql, inform)

      calcAx = .false.
      
      if (inform .lt. 0) then
         if (iprint .ge. 2) then
            write(*, 1008) -70, -inform
            write(10,1008) -70, -inform
         end if
         
         inform = -70
         return
      end if
      
      if (inform .eq. 2) then
         inform = -40
         
         if (iprint .ge. 2) then
            write(*, 1009) inform
            write(10,1009) inform
         end if
         
         return
      end if
      
C     If x_i should be equal to l_i (u_i), but, instead, is too close
C     to it, set x_i = l_i (u_i).
           
      do i = 1,n
         if (x(i) .le. l(i) +
     +        macheps**(2.0d0/3.0d0) * max(abs(l(i)), 1.0d0)) then
            x(i) = l(i)
         end if

         if (x(i) .ge. u(i) -
     +        macheps**(2.0d0/3.0d0) * max(abs(u(i)), 1.0d0)) then
            x(i) = u(i)
         end if
      end do

C     Calculate wd14 = A x.
      
      if (calcAx) then
         do i = 1, ml
            wd14(i) = 0.0d0
         end do
         
         do j = 1, n
            do i = 1, ml
               wd14(i) = wd14(i) + A(i,j) * x(j)
            end do
         end do
      end if

C     Check if point x is feasible.

      csupn = 0.0d0

      do i = 1, mleq
         csupn = max(csupn, abs(wd14(i) - b(i)))
      end do

      do i = mleq+1, ml
         csupn = max(csupn, b(i)-wd14(i))
      end do

      do i = 1, mleq
         if (abs(wd14(i) - b(i)) .gt. epscsn) then

            inform = -40

            if (iprint .ge. 2) then
               write(*, 1011) inform, i
               write(10,1011) inform, i
            end if

            return
         end if
      end do
      
      do i = mleq+1, ml
         if (b(i) - wd14(i) .gt. epscsn) then

            inform = -40

            if (iprint .ge. 2) then
               write(*, 1011) inform, i
               write(10,1011) inform, i
            end if

            return
         end if
      end do

C     Store in nind the number of free variables and in array ind their
C     identifiers.

      nind = 0
      do i = 1, n
         if ((x(i) .gt. l(i)) .and. (x(i) .lt. u(i))) then
            nind = nind + 1
            ind(nind) = i
         end if
      end do
      
      nind2 = nind
      do i = 1, nind2
         ind2(i) = i
      end do
      
C     Store in nact the number of active linear constraints and in
C     array iact their identifiers. The last m - nact positions of
C     iact store the identifier of the non-active linear constraints.
   
      do i = 1, mleq
         iact(i) = i
      end do

      nact = mleq
      k = ml
      
      do i = mleq+1, ml
         if (abs(wd14(i)-b(i)) .le. epscsn) then
            nact = nact + 1
            iact(nact) = i
         else
            iact(k) = i
            k = k - 1
         end if
      end do
         
C     Compute x norms

      xeucn2 = 0.0d0
      xsupn = 0.0d0
      do i = 1,n
          xeucn2 = xeucn2 + x(i) ** 2
          xsupn = max( xsupn, abs( x(i) ) )
      end do

C     Compute function and gradient at the initial point

      call evalobj(n,x,f,inform)
      fcnt = fcnt + 1

      if ( inform .lt. 0 ) then

          if ( frst ) then

              if ( iprint .ge. 2 ) then
                  write(*, *) 
                  write(*, *) 
     +            'f(x) is undefined. A perturbation is computed.'
                  write(10,*) 
                  write(10,*) 
     +            'f(x) is undefined. A perturbation is computed.'
              end if
            
              do i = 1,n
                  px = sqrt(macheps) * max(abs(x(i)),1.0d0)
                  x(i) = x(i) + px - px*drand(seed)
              end do
            
              frst = .false.
              go to 600
            
          end if
         
          if ( iprint .ge. 2 ) then
              write(*, 1000) inform
              write(10,1000) inform
          end if

          return
      end if

      call evalgr(n,x,g,gtype,macheps,inform)
      gcnt = gcnt + 1

      if ( inform .lt. 0 ) then

          if ( frst ) then

              if ( iprint .ge. 2 ) then
                  write(*, *) 
                  write(*, *) 
     +            'g(x) is undefined. A perturbation is computed.'
                  write(10,*) 
                  write(10,*) 
     +            'g(x) is undefined. A perturbation is computed.'
              end if
            
              do i = 1,n
                  px = sqrt(macheps) * max(abs(x(i)),1.0d0)
                  x(i) = x(i) + px - px*drand(seed)
              end do
            
              frst = .false.
              go to 600
            
          end if

          if ( iprint .ge. 2 ) then
              write(*, 1000) inform
              write(10,1000) inform
          end if

          return
      end if

C     Compute discontinuous-project-gradient.

      samefa = .false.
      gotgp  = .true.
      
C     Move all active linear constraints to the first rows of A.
C     Do the same with b. Update array wd14 (= A x).
      
      do j = 1, n
         do i = mleq+1, nact
            ii = iact(i)
            
            if (i .ne. ii) then
               tmp     = A(i,j)
               A(i,j)  = A(ii,j)
               A(ii,j) = tmp
            end if
         end do
      end do
      
      do i = mleq+1, nact
         ii = iact(i)
         
         if (i .ne. ii) then
            tmp   = b(i)
            b(i)  = b(ii)
            b(ii) = tmp
         end if
      end do

      do i = mleq+1, nact
         ii = iact(i)
         
         if (i .ne. ii) then
            tmp      = wd14(i)
            wd14(i)  = wd14(ii)
            wd14(ii) = tmp
         end if
      end do

C     Change indices of active constraints.
      
      do i = mleq+1, nact
         iact(i) = i
      end do
      
      do i = nact+1, ml
         iact(i) = ml + nact + 1 - i
      end do

C     Move all "almost" active linear constraints to the first rows of A.
C     Do the same with b.
      
      tolact = nact
      
      do i = nact+1, ml
         ax = wd14(i)

         if (ax - b(i) .le. toldgptmp*max(1.0d0,abs(b(i)))) then
            
            tolact = tolact + 1
            ii     = tolact
               
            if (i .ne. ii) then
               do j = 1, n
                  tmp     = A(i,j)
                  A(i,j)  = A(ii,j)
                  A(ii,j) = tmp
               end do

               tmp   = b(i)
               b(i)  = b(ii)
               b(ii) = tmp
            end if
         end if
      end do
      
C     Use only active constraits to project

      do i = 1,n
         wd1(i) = x(i) - g(i)
      end do
         
      call project(n, wd1, l, u, tolact, mleq, lda, A, b, promaxit, 
     +     projeps, lossfeas, epscsn, tmp, macheps, wi1, wd3, wd14, 
     +     lwd14, wd4, iterql, inform)
      
      if ((inform .lt. 0) .or. (inform .eq. 2)) then
         
         inform = -30
         
         if (iprint .ge. 2) then
            write(*, 1007) inform
            write(10,1007) inform
         end if
         
         return
      end if
      
      do i = 1,n
         wd1(i) = wd1(i) - x(i)
      end do

C     Compute discontinuous-project-gradient Euclidian and Sup norms.
      
      gpsupn  = 0.0d0
      gpeucn2 = 0.0d0
      
      do i = 1, n
         gpsupn  = max(gpsupn, abs(wd1(i)))
         gpeucn2 = gpeucn2 + wd1(i)**2
      end do
      
C     Test if inicial (projected) point is a solution

C     Test whether the discontinuous-projected-gradient Sup norm
C     is small enough to declare convergence
         
      if ( gpsupn .le. epsgpsn ) then
         inform = 0

         if ( iprint .ge. 2 ) then
            write(*, 991) inform,epsgpsn
            write(10,991) inform,epsgpsn
         end if
         
         go to 500
      end if
            
C     If there is at least 1 active linear constraint, we need
C     to calculate matrix Z.
      
      if (nact .gt. 0) then
         
C        Abar^T is formed by the columns of A corresponding to free
C        variables and rows of A corresponding to active constraints.
      
         do i = 1, nact
            ii = iact(i)
            do j = 1, nind
               jj = ind(j)
               Abar(j,i) = A(ii,jj)
            end do
         end do
      
C        Calculate QR factorization of Abar.

         do i = 1, nact
            wi1(i) = 0
         end do
         
         call DGEQP3(nind, nact, Abar, ldabar, wi1, tau, wd14, lwd14,
     +        inform)

         if (inform .ne. 0) then
            inform = -50
            
            if (iprint .ge. 2) then
               write(*, 1010) inform
               write(10,1010) inform
            end if
            
            return
         end if
            
C        Count the number of LI rows of Abar (that is, the number of
C        non-null diagonal elements of R.

         k = min(nind, nact)
         nliact = 1
 1       if (abs(Abar(nliact,nliact)) .gt. macheps**(2.0d0/3.0d0)) then
            nliact = nliact + 1
            if (nliact .le. k) then
               go to 1
            end if
         end if
         nliact = nliact - 1
      else
         nliact = 0
      end if

C     Compute s = x_aux - x_0, y = g_aux - g_0, <s,s> and <s,y>

      sts = 0.0d0
      sty = 0.0d0
      ssupn = 0.0d0
      seucn = 0.0d0
      yeucn = 0.0d0
      do i = 1,n
          s(i) = 0.0d0
          y(i) = 0.0d0
      end do
      seucn = sqrt( sts )
      yeucn = sqrt( yeucn )

C     Compute a linear relation between gpeucn2 and cgeps2, i.e.,
C     scalars a and b such that 
c
C         a * log10(||g_P(x_0)||_2^2) + b = log10(cgeps_0^2) and
c
C         a * log10(||g_P(x_f)||_2^2) + b = log10(cgeps_f^2),
c
C     where cgeps_0 and cgeps_f are provided. Note that if 
C     cgeps_0 is equal to cgeps_f then cgeps will be always 
C     equal to cgeps_0 and cgeps_f.

C     We introduce now a linear relation between gpsupn and cgeps also.

      if (cgscre .eq. 1) then
          acgeps = 2.0d0 * log10(cgepsf / cgepsi) / 
     +                     log10(cggpnf ** 2 / gpeucn2)
          bcgeps = 2.0d0 * log10(cgepsi) - acgeps * log10(gpeucn2)
      else ! if (cgscre .eq. 2) then
          acgeps = log10(cgepsf / cgepsi) / log10(cggpnf / gpsupn)
          bcgeps = log10(cgepsi) - acgeps * log10(gpsupn)
      end if 

C     And it will be used for the linear relation of cgmaxit

C     gpsupn0  = gpsupn
C     gpeucn20 = gpeucn2

C     Print initial information

      if( iprint .ge. 2 ) then
          write(*, 981) iter
          write(*, 985) nprint,(x(i),  i=1,nprint)
          write(*, 986) nprint,(g(i),  i=1,nprint)
          write(*, 987) nprint,(wd1(i),i=1,nprint)
          write(*, 988) min0(nprint,nind2),nind2,(ind(ind2(i)),
     +    i=1,min0(nprint,nind2))
          write(*, 989) min0(mlprint,nact),nact,(iact(i),
     +    i=1,min0(mlprint,nact))
          write(*, 1004) f,csupn,sqrt(gpeucn2),gpsupn,nind2,n,nact,ml,
     +         spgiter,tniter,ispgiter,triter,fcnt,gcnt,hcnt,cgcnt,chcnt

          write(10,981) iter
          write(10,985) nprint,(x(i),  i=1,nprint)
          write(10,986) nprint,(g(i),  i=1,nprint)
          write(10,987) nprint,(wd1(i),i=1,nprint)
          write(10,988) min0(nprint,nind2),nind2,(ind(ind2(i)),
     +    i=1,min0(nprint,nind2))
          write(10,989) min0(mlprint,nact),nact,(iact(i),
     +    i=1,min0(mlprint,nact))
          write(10,1004) f,csupn,sqrt(gpeucn2),gpsupn,nind2,n,nact,ml,
     +         spgiter,tniter,ispgiter,triter,fcnt,gcnt,hcnt,cgcnt,chcnt
      end if

C     SAVING INTERMEDIATE DATA FOR CRASH REPORT

      open (20,file='genlin-tabline.out')
      write(20,3000) 0.0d0,99,n,ml,iter,fcnt,gcnt,hcnt,cgcnt,chcnt,
     +     spgiter,spgfcnt,tniter,tnfcnt,triter,trfcnt,ispgiter,
     +     ispgfcnt,iterql,f,csupn,gpsupn
      close(20)

C     Set initial trust-region radius.

      if (intype .ne. 1) then
         trdelta = max(trdelmin, trdelini * max(1.0d0, sqrt(xeucn2)))
         newtrdelta = 0.0d0
      end if

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

 100  continue

C     ==================================================================
C     Save current values, f, x and g
C     ==================================================================

      fprev = f

      do i = 1,n
          xprev(i) = x(i)
          gprev(i) = g(i)
      end do

      gotgpp = gotgp

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

C     Test whether the functional value is very small

      if ( f .le. fmin ) then

          inform = 4

          if ( iprint .ge. 2 ) then
              write(*, 994) inform,fmin
              write(10,994) inform,fmin
          end if

          go to 500

      end if

C     Test whether the number of iterations is exhausted

      if ( iter .ge. maxit ) then

          inform = 7

          if ( iprint .ge. 2 ) then
              write(*, 997) inform,maxit
              write(10,997) inform,maxit
          end if

          go to 500

      end if

C     Test whether the number of functional evaluations is exhausted

      if ( fcnt .ge. maxfc ) then

          inform = 8

          if ( iprint .ge. 2 ) then
              write(*, 998) inform,maxfc
              write(10,998) inform,maxfc
          end if

          go to 500

      end if

C     Test whether we performed many iterations without good progress
C     of the functional value

      currprog = abs(fprev - f)
      bestprog = max( currprog, bestprog )

      if ( currprog .le. epsnfp * bestprog ) then
         
         if ( ittype .eq. 1 ) then
            itnfpspg = itnfpspg + 1
            itnfpin  = 0
         else
            itnfpin  = itnfpin + 1
            itnfpspg = 0
         end if
            
         if ( itnfpspg .ge. maxitnfp ) then

            inform = 2
            
            if ( iprint .ge. 2 ) then
               write(*, 992) inform,epsnfp,maxitnfp
               write(10,992) inform,epsnfp,maxitnfp
            end if
            
            go to 500
         end if

         if ( itnfpin .ge. maxitnfp ) then

            if ( iprint .ge. 2 ) then
               write(*,*)  
               write(*,*)  
     +            '     Too many inner iterations were performed with ',
     +            '     no progress of the objective function. A PSPG ',
     +            '     iteration will be forced now. '

               write(10,*)  
               write(10,*)
     +            '     Too many inner iterations were performed with ',
     +            '     no progress of the objective function. A PSPG ',
     +            '     iteration will be forced now. '
            end if
              
            spgiter = spgiter + 1
            iter    = iter    + 1

C           Set iteration type
              
            ittype = 1

C           Compute spectral steplength
               
            if ( sty .le. 0.0d0 ) then
               lamspg = 1.0d0
            else
               lamspg = sts / sty
            end if
            lamspg = min( lspgma, max( lspgmi, lamspg ) )
         
            if (gotgp .and. (lamspg .eq. 1.0d0)) then
               do i = 1, n
                  wd2(i) = wd1(i)
               end do
               gotd = .true.
            else
               gotd = .false.
            end if
            
C           Perform a line search with safeguarded quadratic 
C           interpolation along the direction of the spectral 
C           discontinuous projected gradient

            fcntprev = fcnt

            call pspgls(n,x,f,g,l,u,ml,mleq,lda,A,b,nact,iact,gotgp,
     +      tolact,lamspg,etaint,mininterp,fmin,maxfc,iprint,wd1,stlen,
     +      gotd,wd2,gamma,sigma1,sigma2,lossfeas,epscsn,projeps,
     +      promaxit,macheps,toldgptmp,wi1,wd3,wd14,lwd14,wd15,wd4,fcnt,
     +      intnan,iterql,inform)
              
            spgfcnt = spgfcnt + ( fcnt - fcntprev )
              
            if ( inform .ne. 6 ) then
               gotgp  = .false.
            end if
            
            if ( inform .lt. 0 ) then
               
               if ( iprint .ge. 2 ) then
                  write(*, 1000) inform
                  write(10,1000) inform
               end if
               
               return
            end if
            
            if ( inform .eq. 10 ) then

               if ( iprint .ge. 2 ) then
                  write(*, 1012) inform
                  write(10,1012) inform
               end if

               go to 500
            end if

C           Calculate wd14 = A x.
            
            do i = 1, ml
               wd14(i) = 0.0d0
            end do
            
            do j = 1, n
               do i = 1, ml
                  wd14(i) = wd14(i) + A(i,j) * x(j)
               end do
            end do
      
C           Compute sup-norm of the linear constraits
      
            csupn = 0.0d0
            
            do i = 1, mleq
               csupn = max(csupn, abs(wd14(i) - b(i)))
            end do
            
            do i = mleq+1, ml
               csupn = max(csupn, b(i)-wd14(i))
            end do
      
C           Compute the gradient at the new iterate
              
            infotmp = inform
            
            call evalgr(n,x,g,gtype,macheps,inform)
            gcnt = gcnt + 1
            
            if ( inform .lt. 0 ) then
               
               if ( iprint .ge. 2 ) then
                  write(*, 1000) inform
                  write(10,1000) inform
               end if
               
               return
            end if
            
            inform = infotmp
            
C           Compute gradient Euclidian and Sup norms.
      
            gsupn = 0.0d0
            
            do i = 1, n
               gsupn = max(gsupn, abs(g(i)))
            end do
            
C           If gradient norm is smaller than eps, the norm of the
C           discontinuous-project-gradient is also smaller than eps. 
C           In this case, the algorithm stops.

            if (gsupn .le. epsgpsn) then
               
               gotgp = .true. 
               
C              Move all active linear constraints to the first rows of 
C              A. Do the same with b. 
      
               do j = 1, n
                  do i = mleq+1, nact
                     ii = iact(i)
                     
                     if (i .ne. ii) then
                        tmp     = A(i,j)
                        A(i,j)  = A(ii,j)
                        A(ii,j) = tmp
                     end if
                  end do
               end do
               
               do i = mleq+1, nact
                  ii = iact(i)
                  
                  if (i .ne. ii) then
                     tmp   = b(i)
                     b(i)  = b(ii)
                     b(ii) = tmp
                  end if
               end do
              
C              Change indices of active constraints.
              
               do i = mleq+1, nact
                  iact(i) = i
               end do
               
               do i = nact+1, ml
                  iact(i) = ml + nact + 1 - i
               end do
               
C              Move all "almost" active linear constraints to the 
C              first rows of A. Do the same with b.
      
               tolact = nact
               
               do i = nact+1, ml
                  wd15(i) = 0.0d0
               end do
               
               do j = 1, n
                  do i = nact+1, ml
                     wd15(i) = wd15(i) + A(i,j) * x(j)
                  end do
               end do
               
               do i = nact+1, ml
                  ax = wd15(i)
                  
                  if (ax-b(i) .le. toldgptmp*max(1.0d0,abs(b(i)))) then
                     
                     tolact = tolact + 1
                     ii     = tolact
                     
                     if (i .ne. ii) then
                        do j = 1, n
                           tmp     = A(i,j)
                           A(i,j)  = A(ii,j)
                           A(ii,j) = tmp
                        end do
                        
                        tmp   = b(i)
                        b(i)  = b(ii)
                        b(ii) = tmp
                     end if
                  end if
               end do
               
C              Use only active constraits to project
      
               do i = 1,n
                  wd1(i) = x(i) - g(i)
               end do
               
               infotmp = inform
               
               call project(n, wd1, l, u, tolact, mleq, lda, A, b, 
     +              promaxit, projeps, lossfeas, epscsn, tmp, macheps,
     +              wi1, wd3, wd14, lwd14, wd4, iterql, inform)
               
               if ((inform .lt. 0) .or. (inform .eq. 2)) then
                  
                  if ( iprint .ge. 2 ) then
                     write(*,*)  
                     write(*,*)  
     +            '     Problem in projection subroutine. Projected   ',
     +            '     gradient could not be calculated.             '
               
                     write(10,*)  
                     write(10,*)  
     +            '     Problem in projection subroutine. Projected   ',
     +            '     gradient could not be calculated.             '
                  end if
            
                  inform  = infotmp
                  gpsupn  = 1.0d+99
                  gpeucn2 = 1.0d+99
                  
               else
                  
                  inform = infotmp
                  
                  do i = 1,n
                     wd1(i) = wd1(i) - x(i)
                  end do
                  
C                 Compute discontinuous-project-gradient Euclidian and 
C                 Sup norms.
            
                  gpsupn  = 0.0d0
                  gpeucn2 = 0.0d0
                  
                  do i = 1, n
                     gpsupn  = max(gpsupn, abs(wd1(i)))
                     gpeucn2 = gpeucn2 + wd1(i)**2
                  end do
               end if

C              Test whether the discontinuous-projected-gradient Sup
C              norm is small enough to declare convergence
         
               if ( gpsupn .le. epsgpsn ) then
                  inform = 0

                  if ( iprint .ge. 2 ) then
                     write(*, 991) inform,epsgpsn
                     write(10,991) inform,epsgpsn
                  end if
                  
                  go to 500
               end if
            end if

            go to 300
         end if
      else
         itnfpin  = 0
         itnfpspg = 0          
      end if

C     ==================================================================
C     The stopping criteria were not satisfied, a new iteration will be 
C     made
C     ==================================================================

 110  continue

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

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

C     Decide which inner algorithm will be used to compute the next 
C     point

      if (intype .eq. 1) then
         gencan = .true.
             
      elseif (intype .eq. 2) then
         gencan = .false.
         
      else ! (intype .eq. 0) then
         if (.not. gencan .and. ((informprev .eq. 5) .or. 
     +        (informprev .eq. 6))) then
            gencan = .true.
         elseif ((triter .ne. triterprev) .and.
     +           (triter-triterprev .ge. 7)) then
            gencan = .true.
         elseif ((chcnt .ne. chcntprev) .and. (chcnt-chcntprev
     +           .ge. 10 * (triter-triterprev))) then
            gencan = .true.
         elseif (gencan .and. (informprev .eq. 6)) then
            gencan = .false.
         elseif ((cgcnt .ne. 0) .and. 
     +           (cgcnt - cgcntprev .ge. 0.6 * n)) then
            gencan = .false.
         elseif (n .le. 50) then
            gencan = .false.
         else
            gencan = .true.
         end if
      end if
       
C     Shrink gradient
         
      call shrink(nind, ind, n, g)
      
C     Project gradient onto null space of active constraints. If
C     there is no active constraints, gz = g.
      
      if (nact .gt. 0) then
         call multZT(nind, nliact, ldabar, Abar, tau, g, wd1, gz,
     +        macheps)
      else
         do i = 1, nind
            gz(i) = g(i)
         end do
      end if
      
      gzsupn = 0.0d0
      do i = 1, nind-nliact
         gzsupn = max(gzsupn, abs(gz(i)))
      end do
      
C     If the projection of the gradient onto null space of active
C     constraints is null, x is the minimizer in the current face.
C     The projected gradient is computed now to check if the point 
C     is stationary. If it is not, use PSPG to leave the face.
      
      if (gzsupn .le. epsgpsn) then
      
C        Expand gradient
         
         call expand(nind, ind, n, g)
         
C        Move all active linear constraints to the first rows of A.
C        Do the same with b. 
      
         do j = 1, n
            do i = mleq+1, nact
               ii = iact(i)
               
               if (i .ne. ii) then
                  tmp     = A(i,j)
                  A(i,j)  = A(ii,j)
                  A(ii,j) = tmp
               end if
            end do
         end do
         
         do i = mleq+1, nact
            ii = iact(i)
            
            if (i .ne. ii) then
               tmp   = b(i)
               b(i)  = b(ii)
               b(ii) = tmp
            end if
         end do
         
C        Change indices of active constraints.
      
         do i = mleq+1, nact
            iact(i) = i
         end do
         
         do i = nact+1, ml
            iact(i) = ml + nact + 1 - i
         end do
         
C        Move all "almost" active linear constraints to the first rows 
C        of A. Do the same with b.
      
         tolact = nact
         
         do i = nact+1, ml
            wd15(i) = 0.0d0
         end do
         
         do j = 1, n
            do i = nact+1, ml
               wd15(i) = wd15(i) + A(i,j) * x(j)
            end do
         end do

         do i = nact+1, ml
            ax = wd15(i)
            
            if (ax - b(i) .le. toldgptmp*max(1.0d0,abs(b(i)))) then
               
               tolact = tolact + 1
               ii     = tolact
               
               if (i .ne. ii) then
                  do j = 1, n
                     tmp     = A(i,j)
                     A(i,j)  = A(ii,j)
                     A(ii,j) = tmp
                  end do
                  
                  tmp   = b(i)
                  b(i)  = b(ii)
                  b(ii) = tmp
                  
                  tmp      = wd15(i)
                  wd15(i)  = wd15(ii)
                  wd15(ii) = tmp
               end if
            end if
         end do
         
C        Compute spectral steplength
      
         if ( sty .le. 0.0d0 ) then
            lamspg = 1.0d0
         else
            lamspg = sts / sty
         end if
         lamspg = min( lspgma, max( lspgmi, lamspg ) )

C        Use only active constraits to project

         do i = 1,n
            wd2(i) = x(i) - lamspg * g(i)
         end do

         infotmp = inform
         
         call project(n, wd2, l, u, tolact, mleq, lda, A, b, promaxit, 
     +        projeps, lossfeas, epscsn, tmp, macheps, wi1, wd3, wd14, 
     +        lwd14, wd4, iterql, inform)
         
         if ((inform .lt. 0) .or. (inform .eq. 2)) then
            
            inform = -30
            
            if (iprint .ge. 2) then
               write(*, 1007) inform
               write(10,1007) inform
            end if
            
            return
         end if
         
         inform = infotmp

         do i = 1,n
            wd2(i) = wd2(i) - x(i)
         end do

C        Compute maximum step.

         do i = tolact+1, ml
            wd14(i) = 0.0d0
         end do
         
         do j = 1, n
            do i = tolact+1, ml
               wd14(i) = wd14(i) + A(i,j) * wd2(j)
            end do
         end do
         
         maxstp = 1.0d0
         
         do i = tolact+1, ml
            ad = wd14(i)
            ax = wd15(i)
            
            if (ad .lt. 0.0d0) then
               maxstp = min(maxstp, (b(i) - ax) / ad)
            end if
         end do
         
         do i = 1,n
            wd2(i) = maxstp * wd2(i)
         end do

C        Compute spectral-discontinuous-project-gradient Euclidian and Sup norms.
                
         sgpsupn = 0.0d0
         
         do i = 1, n
            sgpsupn = max(sgpsupn, abs(wd2(i)))
         end do

C        If spectral step is 1, both spectral-discontinuous-project-
C        gradient and discontinuous-project-gradient are the same.

         if (lamspg .eq. 1.0d0) then
            do i = 1, n
               wd1(i) = wd2(i)/maxstp
            end do

            gpsupn = sgpsupn/maxstp
            gotgp  = .true.

C           Test whether the discontinuous-projected-gradient Sup norm
C           is small enough to declare convergence

            if ( gpsupn .le. epsgpsn ) then
               inform = 0

               if ( iprint .ge. 2 ) then
                  write(*, 991) inform,epsgpsn
                  write(10,991) inform,epsgpsn
               end if
               
               go to 500
            end if
          
C           If the projection of the gradient onto null space of active
C           constraints is null, x is the minimizer in the current face.
C           The algorithm decided to stay in the current face, but there
C           is nothing to be done in it. So, a PSPG iteration is performed.

            if (iprint .ge. 2) then
               write(*, *)  
               write(*, *)  
     +           '   The current point is a minimizer of the',
     +           '   current face. A PSPG iteration will be used now.'
            
               write(10,*)  
               write(10,*)  
     +           '   The current point is a minimizer of the',
     +           '   current face. A PSPG iteration will be used now.'
            end if
      
            gotd = .true.
            go to 200

C        If norm of spectral-discontinuous-project-gradient says the
C        current point is not a solution, perform a PSPG iteration to 
C        leave the current face, without computing the discontinuous
C        project-gradient.

         elseif (((lamspg .gt. 1.0d0) .and. 
     +            (sgpsupn/maxstp .ge. lamspg*epsgpsn)) .or.
     +          ((lamspg .lt. 1.0d0) .and. 
     +           (sgpsupn/maxstp .ge. epsgpsn))) then
            
            if (iprint .ge. 2) then
               write(*, *)  
               write(*, *)  
     +           '   The current point is a minimizer of the',
     +           '   current face. A PSPG iteration will be used now.'
            
               write(10,*)  
               write(10,*)  
     +           '   The current point is a minimizer of the',
     +           '   current face. A PSPG iteration will be used now.'
            end if

            gotgp = .false. 
            gotd  = .true.
            go to 200

C        If norm of spectral-discontinuous-project-gradient says the
C        current point is a solution, compute the discontinuous
C        project-gradient and stop the algorithm.

         elseif (((lamspg .gt. 1.0d0) .and. 
     +            (sgpsupn/maxstp .le. epsgpsn)) .or. 
     +           ((lamspg .lt. 1.0d0) .and. 
     +            (lamspg .ge. sqrt(macheps)) .and.
     +            (sgpsupn/maxstp .le. lamspg * epsgpsn))) then

            gotgp = .true.

            do i = 1,n
               wd1(i) = x(i) - g(i)
            end do

            infotmp = inform
            
            call project(n, wd1, l, u, tolact, mleq, lda, A, b, 
     +           promaxit, projeps, lossfeas, epscsn, tmp, macheps, wi1,
     +           wd3, wd14, lwd14, wd4, iterql, inform)

            if ((inform .lt. 0) .or. (inform .eq. 2)) then
               
               if ( iprint .ge. 2 ) then
                  write(*,*)  
                  write(*,*)  
     +            '     Problem in projection subroutine. Projected   ',
     +            '     gradient could not be calculated.             '
               
                  write(10,*)  
                  write(10,*)  
     +            '     Problem in projection subroutine. Projected   ',
     +            '     gradient could not be calculated.             '
               end if
            
               inform  = infotmp
               gpsupn  = 1.0d+99
               gpeucn2 = 1.0d+99
               
            else
               
               inform = infotmp
               
               do i = 1,n
                  wd1(i) = wd1(i) - x(i)
               end do
               
C              Compute discontinuous-project-gradient Euclidian and Sup norms.
            
               gpsupn  = 0.0d0
               gpeucn2 = 0.0d0
               
               do i = 1, n
                  gpsupn  = max(gpsupn, abs(wd1(i)))
                  gpeucn2 = gpeucn2 + wd1(i)**2
               end do
            end if
         
C           Test whether the discontinuous-projected-gradient Sup norm is 
C           small enough to declare convergence
         
            if ( gpsupn .le. epsgpsn ) then
               inform = 0

               if ( iprint .ge. 2 ) then
                  write(*, 991) inform,epsgpsn
                  write(10,991) inform,epsgpsn
               end if
               
               go to 500
            end if

C           If the projection of the gradient onto null space of active
C           constraints is null, x is the minimizer in the current face.
C           The algorithm decided to stay in the current face, but there
C           is nothing to be done in it. So, a PSPG iteration is performed.

            if (iprint .ge. 2) then
               write(*, *)  
               write(*, *)  
     +           '   The current point is a minimizer of the',
     +           '   current face. A PSPG iteration will be used now.'
            
               write(10,*)  
               write(10,*)  
     +           '   The current point is a minimizer of the',
     +           '   current face. A PSPG iteration will be used now.'
            end if

            gotd = .true.
            go to 200

C        If norm of spectral-discontinuous-project-gradient does not give 
C        any information about the norm of the discontinuous-project-
C        gradient, compute the latter and decide if the current point is 
C        a solution or if the algorithm should leave the current face.

         else
 
            gotgp = .true.
            
            do i = 1,n
               wd1(i) = x(i) - g(i)
            end do

            infotmp = inform
            
            call project(n, wd1, l, u, tolact, mleq, lda, A, b, 
     +           promaxit, projeps, lossfeas, epscsn, tmp, macheps, wi1,
     +           wd3, wd14, lwd14, wd4, iterql, inform)
         
            if ((inform .lt. 0) .or. (inform .eq. 2)) then
               
               inform = -30
               
               if (iprint .ge. 2) then
                  write(*, 1007) inform
                  write(10,1007) inform
               end if
               
               return
            end if
            
            inform = infotmp
            
            do i = 1,n
               wd1(i) = wd1(i) - x(i)
            end do
            
C           Compute discontinuous-project-gradient Euclidian and Sup 
C           norms.
            
            gpsupn  = 0.0d0
            gpeucn2 = 0.0d0
            
            do i = 1, n
               gpsupn  = max(gpsupn, abs(wd1(i)))
               gpeucn2 = gpeucn2 + wd1(i)**2
            end do
                        
C           Test whether the discontinuous-projected-gradient Sup norm
C           is small enough to declare convergence

            if ( gpsupn .le. epsgpsn ) then
               inform = 0

               if ( iprint .ge. 2 ) then
                  write(*, 991) inform,epsgpsn
                  write(10,991) inform,epsgpsn
               end if
               
               go to 500
            end if
          
C           If the projection of the gradient onto null space of active
C           constraints is null, x is the minimizer in the current face.
C           The algorithm decided to stay in the current face, but there
C           is nothing to be done in it. So, a PSPG iteration is performed.

            if (iprint .ge. 2) then
               write(*, *)  
               write(*, *)  
     +           '   The current point is a minimizer of the',
     +           '   current face. A PSPG iteration will be used now.'

               write(10,*)  
               write(10,*)  
     +           '   The current point is a minimizer of the',
     +           '   current face. A PSPG iteration will be used now.'
            end if
         
            gotd = .true.
            go to 200
         end if
      end if

C     Shrink the point, its gradient and the bounds
      
      call shrink(nind,ind,n,x)
      call shrink(nind,ind,n,l)
      call shrink(nind,ind,n,u)
      
      cgcntprev  = cgcnt
      triterprev = triter
      chcntprev  = chcnt
      
      iter       = iter + 1

      if (gencan) then
         
         if ( ( precond .eq. 'QNCGNA' ) .and. ( nact .gt. 0 ) ) then
            precondd = 'NONE'
         else
            precondd = precond
         end if
         
         call wfgencan(n,nind,ind,nind2,ind2,x,l,u,ml,mleq,lda,A,b,f,g,
     +   gz,nact,nliact,iact,ldabar,Abar,tau,iter,xsupn,xeucn2,gotgp,
     +   gpsupn,gpeucn2,s,y,ssupn,seucn,yeucn,sts,sty,gtype,hptype,
     +   trtype,precondd,iprint,ncomp,cgepsf,cgepsi,cgscre,acgeps,
     +   bcgeps,delmin,ucgmia,ucgmib,udelta0,epsnqmp,maxitnqmp,theta,
     +   lossfeas,epscsn,macheps,bignum,samefa,lspgmi,lspgma,etaint,
     +   mininterp,fmin,maxfc,gamma,sigma1,sigma2,d,dz,wi1,wd1,wd2,wd3,
     +   wd4,wd5,wd6,wd7,wd8,wd9,wd10,wd11,wd12,wd13,wd15,ittype,rbdlu,
     +   rbdli,rbdind,fcnt,gcnt,hcnt,cgcnt,tniter,tnfcnt,tnstpcnt,
     +   tnintcnt,tnintfe,inform)
         
         informprev = inform
         
      else
         
         call wfbetra(n,nind,ind,nind2,ind2,x,l,u,ml,mleq,lda,A,b,nact,
     +   nliact,iact,samefa,gtype,f,g,gz,gzsupn,trdelta,newtrdelta,
     +   mslamb,msrho,mseps,msmaxit,phieps,mssig,alpha,trdelmin,epsgpsn,
     +   gamma,lspgmi,lspgma,sigma1,sigma2,etaint,mininterp,fmin,
     +   lossfeas,epscsn,projeps,promaxit,macheps,iprint,ncomp,xeucn2,
     +   sts,sty,maxfc,ldh,H,wd1,ldabar,Abar,tau,wi1,d,dz,wd3,wd14,
     +   lwd14,wd4,wd5,wd6,wd15,rbdlu,rbdli,rbdind,triter,trfcnt,
     +   ispgiter,ispgfcnt,fcnt,gcnt,hcnt,chcnt,iterql,ittype,inform)
         
         informprev = inform
                  
      end if
      
C     Expand the point, its gradient and the bounds
      
      call expand(nind,ind,n,x)
      call expand(nind,ind,n,g)
      call expand(nind,ind,n,l)
      call expand(nind,ind,n,u)
      
      if ( inform .lt. 0 ) then
         
         if ( iprint .ge. 2 ) then
            write(*, 1000) inform
            write(10,1000) inform
         end if
         
         return
      end if

C     Calculate wd14 = A x.

      do i = 1, ml
         wd14(i) = 0.0d0
      end do
      
      do j = 1, n
         do i = 1, ml
            wd14(i) = wd14(i) + A(i,j) * x(j)
         end do
      end do
      
C     Compute sup-norm of the linear constraits
      
      csupn = 0.0d0

      do i = 1, mleq
         csupn = max(csupn, abs(wd14(i) - b(i)))
      end do

      do i = mleq+1, ml
         csupn = max(csupn, b(i)-wd14(i))
      end do

C     Compute gradient Euclidian and Sup norms.
      
      gsupn = 0.0d0
      
      do i = 1, n
         gsupn = max(gsupn, abs(g(i)))
      end do
      
C     If gradient norm is smaller than eps, the norm of the
C     discontinuous-project-gradient is also smaller than eps. 
C     In this case, the algorithm stops.
      
      if (gsupn .le. epsgpsn) then

         gotgp = .true. 
         
C        Move all active linear constraints to the first rows of A.
C        Do the same with b. 
         
         do j = 1, n
            do i = mleq+1, nact
               ii = iact(i)
               
               if (i .ne. ii) then
                  tmp     = A(i,j)
                  A(i,j)  = A(ii,j)
                  A(ii,j) = tmp
               end if
            end do
         end do
         
         do i = mleq+1, nact
            ii = iact(i)
            
            if (i .ne. ii) then
               tmp   = b(i)
               b(i)  = b(ii)
               b(ii) = tmp
            end if
         end do
         
C        Change indices of active constraints.
              
         do i = mleq+1, nact
            iact(i) = i
         end do
         
         do i = nact+1, ml
            iact(i) = ml + nact + 1 - i
         end do
         
C        Move all "almost" active linear constraints to the first rows 
C        of A. Do the same with b.
      
         tolact = nact
         
         do i = nact+1, ml
            wd15(i) = 0.0d0
         end do
         
         do j = 1, n
            do i = nact+1, ml
               wd15(i) = wd15(i) + A(i,j) * x(j)
            end do
         end do
         
         do i = nact+1, ml
            ax = wd15(i)
            
            if (ax - b(i) .le. toldgptmp*max(1.0d0,abs(b(i)))) then
               
               tolact = tolact + 1
               ii     = tolact
               
               if (i .ne. ii) then
                  do j = 1, n
                     tmp     = A(i,j)
                     A(i,j)  = A(ii,j)
                     A(ii,j) = tmp
                  end do
                  
                  tmp   = b(i)
                  b(i)  = b(ii)
                  b(ii) = tmp
               end if
            end if
         end do
         
C        Use only active constraits to project
         
         do i = 1,n
            wd1(i) = x(i) - g(i)
         end do

         infotmp = inform
         
         call project(n, wd1, l, u, tolact, mleq, lda, A, b, promaxit, 
     +        projeps, lossfeas, epscsn, tmp, macheps, wi1, wd3, wd14, 
     +        lwd14, wd4, iterql, inform)

         if ((inform .lt. 0) .or. (inform .eq. 2)) then

            if ( iprint .ge. 2 ) then
               write(*,*)  
               write(*,*)  
     +            '     Problem in projection subroutine. Projected   ',
     +            '     gradient could not be calculated.             '
               
               write(10,*)  
               write(10,*)  
     +            '     Problem in projection subroutine. Projected   ',
     +            '     gradient could not be calculated.             '
            end if
            
            inform  = infotmp
            gpsupn  = 1.0d+99
            gpeucn2 = 1.0d+99
            
         else
            
            inform = infotmp
            
            do i = 1,n
               wd1(i) = wd1(i) - x(i)
            end do
            
C           Compute discontinuous-project-gradient Euclidian and Sup norms.
            
            gpsupn  = 0.0d0
            gpeucn2 = 0.0d0
            
            do i = 1, n
               gpsupn  = max(gpsupn, abs(wd1(i)))
               gpeucn2 = gpeucn2 + wd1(i)**2
            end do
         end if
         
C        Test whether the discontinuous-projected-gradient Sup norm is 
C        small enough to declare convergence
         
         if ( gpsupn .le. epsgpsn ) then
            inform = 0

            if ( iprint .ge. 2 ) then
               write(*, 991) inform,epsgpsn
               write(10,991) inform,epsgpsn
            end if
            
            go to 500
         end if
      end if

C     If one of these stopping criteria were satisfied by the inner 
C     algorithm, the point x might be a solution. So, the discontinuous 
C     projected is computed
      
      if ( ( inform .eq. 6 ) .or. ( inform .eq. 10 ) .or. 
     +     ( ( .not. gencan ) .and. ( ( inform .eq. 1 ) .or. 
     +     ( inform .eq. 2 ) .or. ( inform .eq. 5 ) ) ) ) then
                      
C        Move all active linear constraints to the first rows of A.
C        Do the same with b. 
      
         do j = 1, n
            do i = mleq+1, nact
               ii = iact(i)
               
               if (i .ne. ii) then
                  tmp     = A(i,j)
                  A(i,j)  = A(ii,j)
                  A(ii,j) = tmp
               end if
            end do
         end do
         
         do i = mleq+1, nact
            ii = iact(i)
            
            if (i .ne. ii) then
               tmp   = b(i)
               b(i)  = b(ii)
               b(ii) = tmp
            end if
         end do
         
C        Change indices of active constraints.
      
         do i = mleq+1, nact
            iact(i) = i
         end do
         
         do i = nact+1, ml
            iact(i) = ml + nact + 1 - i
         end do
         
C        Move all "almost" active linear constraints to the first rows 
C        of A. Do the same with b.
      
         tolact = nact
         
         do i = nact+1, ml
            wd15(i) = 0.0d0
         end do
         
         do j = 1, n
            do i = nact+1, ml
               wd15(i) = wd15(i) + A(i,j) * x(j)
            end do
         end do

         do i = nact+1, ml
            ax = wd15(i)
            
            if (ax - b(i) .le. toldgptmp*max(1.0d0,abs(b(i)))) then
               
               tolact = tolact + 1
               ii     = tolact
               
               if (i .ne. ii) then
                  do j = 1, n
                     tmp     = A(i,j)
                     A(i,j)  = A(ii,j)
                     A(ii,j) = tmp
                  end do
                  
                  tmp   = b(i)
                  b(i)  = b(ii)
                  b(ii) = tmp
                  
                  tmp      = wd15(i)
                  wd15(i)  = wd15(ii)
                  wd15(ii) = tmp
               end if
            end if
         end do
         
C        Compute spectral steplength
      
         if ( sty .le. 0.0d0 ) then
            lamspg = 1.0d0
         else
            lamspg = sts / sty
         end if
         lamspg = min( lspgma, max( lspgmi, lamspg ) )

C        Use only active constraits to project

         do i = 1,n
            wd2(i) = x(i) - lamspg * g(i)
         end do

         infotmp = inform
         
         call project(n, wd2, l, u, tolact, mleq, lda, A, b, promaxit, 
     +        projeps, lossfeas, epscsn, tmp, macheps, wi1, wd3, wd14, 
     +        lwd14, wd4, iterql, inform)
         
         if ((inform .lt. 0) .or. (inform .eq. 2)) then
            
            inform = -30
            
            if (iprint .ge. 2) then
               write(*, 1007) inform
               write(10,1007) inform
            end if
            
            return
         end if
         
         inform = infotmp

         do i = 1,n
            wd2(i) = wd2(i) - x(i)
         end do

C        Compute maximum step.

         do i = tolact+1, ml
            wd14(i) = 0.0d0
         end do
         
         do j = 1, n
            do i = tolact+1, ml
               wd14(i) = wd14(i) + A(i,j) * wd2(j)
            end do
         end do
         
         maxstp = 1.0d0
         
         do i = tolact+1, ml
            ad = wd14(i)
            ax = wd15(i)
            
            if (ad .lt. 0.0d0) then
               maxstp = min(maxstp, (b(i) - ax) / ad)
            end if
         end do
         
         do i = 1,n
            wd2(i) = maxstp * wd2(i)
         end do

C        Compute spectral-discontinuous-project-gradient Euclidian and Sup norms.
                
         sgpsupn = 0.0d0
         
         do i = 1, n
            sgpsupn = max(sgpsupn, abs(wd2(i)))
         end do

C        If spectral step is 1, both spectral-discontinuous-project-
C        gradient and discontinuous-project-gradient are the same.

         if (lamspg .eq. 1.0d0) then
            do i = 1, n
               wd1(i) = wd2(i)/maxstp
            end do

            gpsupn = sgpsupn/maxstp
            gotgp  = .true.
            
C           Test whether the discontinuous-projected-gradient Sup norm
C           is small enough to declare convergence

            if ( gpsupn .le. epsgpsn ) then
               inform = 0

               if ( iprint .ge. 2 ) then
                  write(*, 991) inform,epsgpsn
                  write(10,991) inform,epsgpsn
               end if
               
               go to 500
            end if
          
C           If the projection of the gradient onto null space of active
C           constraints is null, x is the minimizer in the current face.
C           The algorithm decided to stay in the current face, but there
C           is nothing to be done in it. So, a PSPG iteration is performed.

            gotd = .true.

C        If norm of spectral-discontinuous-project-gradient says the
C        current point is not a solution, perform a PSPG iteration to 
C        leave the current face, without computing the discontinuous
C        project-gradient.

         elseif (((lamspg .gt. 1.0d0) .and. 
     +            (sgpsupn/maxstp .ge. lamspg*epsgpsn)) .or.
     +          ((lamspg .lt. 1.0d0) .and. 
     +           (sgpsupn/maxstp .ge. epsgpsn))) then
           
            gotgp = .false. 
            gotd  = .true.

C        If norm of spectral-discontinuous-project-gradient says the
C        current point is a solution, compute the discontinuous
C        project-gradient and stop the algorithm.

         elseif (((lamspg .gt. 1.0d0) .and. 
     +            (sgpsupn/maxstp .le. epsgpsn)) .or. 
     +           ((lamspg .lt. 1.0d0) .and. 
     +            (lamspg .ge. sqrt(macheps)) .and.
     +            (sgpsupn/maxstp .le. lamspg * epsgpsn))) then

            gotgp = .true.

            do i = 1,n
               wd1(i) = x(i) - g(i)
            end do

            infotmp = inform
            
            call project(n, wd1, l, u, tolact, mleq, lda, A, b, 
     +           promaxit, projeps, lossfeas, epscsn, tmp, macheps, wi1,
     +           wd3, wd14, lwd14, wd4, iterql, inform)

            if ((inform .lt. 0) .or. (inform .eq. 2)) then
               
               if ( iprint .ge. 2 ) then
                  write(*,*)  
                  write(*,*)  
     +            '     Problem in projection subroutine. Projected   ',
     +            '     gradient could not be calculated.             '
               
                  write(10,*)  
                  write(10,*)  
     +            '     Problem in projection subroutine. Projected   ',
     +            '     gradient could not be calculated.             '
               end if
            
               inform  = infotmp
               gpsupn  = 1.0d+99
               gpeucn2 = 1.0d+99
               
            else
               
               inform = infotmp
               
               do i = 1,n
                  wd1(i) = wd1(i) - x(i)
               end do
               
C              Compute discontinuous-project-gradient Euclidian and Sup norms.
            
               gpsupn  = 0.0d0
               gpeucn2 = 0.0d0
               
               do i = 1, n
                  gpsupn  = max(gpsupn, abs(wd1(i)))
                  gpeucn2 = gpeucn2 + wd1(i)**2
               end do
            end if
         
C           Test whether the discontinuous-projected-gradient Sup norm is 
C           small enough to declare convergence
         
            if ( sgpsupn/maxstp .le. epsgpsn ) then
               inform = 0

               if ( iprint .ge. 2 ) then
                  write(*, 991) inform,epsgpsn
                  write(10,991) inform,epsgpsn
               end if
               
               go to 500
            end if

C           If the projection of the gradient onto null space of active
C           constraints is null, x is the minimizer in the current face.
C           The algorithm decided to stay in the current face, but there
C           is nothing to be done in it. So, a PSPG iteration is performed.

            gotd = .true.

C        If norm of spectral-discontinuous-project-gradient does not give 
C        any information about the norm of the discontinuous-project-
C        gradient, compute the latter and decide if the current point is 
C        a solution or if the algorithm should leave the current face.

         else
 
            gotgp = .true.
            
            do i = 1,n
               wd1(i) = x(i) - g(i)
            end do

            infotmp = inform
            
            call project(n, wd1, l, u, tolact, mleq, lda, A, b, 
     +           promaxit, projeps, lossfeas, epscsn, tmp, macheps, wi1,
     +           wd3, wd14, lwd14, wd4, iterql, inform)
         
            if ((inform .lt. 0) .or. (inform .eq. 2)) then
               
               inform = -30
               
               if (iprint .ge. 2) then
                  write(*, 1007) inform
                  write(10,1007) inform
               end if
               
               return
            end if
            
            inform = infotmp
            
            do i = 1,n
               wd1(i) = wd1(i) - x(i)
            end do
            
C           Compute discontinuous-project-gradient Euclidian and Sup 
C           norms.
            
            gpsupn  = 0.0d0
            gpeucn2 = 0.0d0
            
            do i = 1, n
               gpsupn  = max(gpsupn, abs(wd1(i)))
               gpeucn2 = gpeucn2 + wd1(i)**2
            end do
                        
C           Test whether the discontinuous-projected-gradient Sup norm
C           is small enough to declare convergence

            if ( gpsupn .le. epsgpsn ) then
               inform = 0

               if ( iprint .ge. 2 ) then
                  write(*, 991) inform,epsgpsn
                  write(10,991) inform,epsgpsn
               end if
               
               go to 500
            end if
          
C           If the projection of the gradient onto null space of active
C           constraints is null, x is the minimizer in the current face.
C           The algorithm decided to stay in the current face, but there
C           is nothing to be done in it. So, a PSPG iteration is performed.

            gotd = .true.
         end if
      else
         gotgp = .false.
      end if

C     If the line search (interpolation) in the Truncated Newton
C     direction stopped due to a very small step (inform = 6), we 
C     will discard this iteration and force a PSPG iteration

      if ( inform .eq. 10 ) then
         
         if ( iprint .ge. 2 ) then
            write(*,*)  
            write(*,*)  
     +            '     It was not possible to compute direction due  ',
     +            '     to reounding errors. A PSPG iteration will be ',
     +            '     forced now.                                   '
            write(10,*)  
            write(10,*)  
     +            '     It was not possible to compute direction due  ',
     +            '     to reounding errors. A PSPG iteration will be ',
     +            '     forced now.                                   '
         end if
         
         go to 200
      end if

C     Note that tnls subroutine was coded in such a way that in case
C     of inform = 6 termination the subroutine discards all what was 
C     done and returns with the same point it started
      
      if ( gencan .and. inform .eq. 6 ) then
         
         if ( iprint .ge. 2 ) then
            write(*,*)  
            write(*,*)  
     +           '     The previous Newtonian iteration was discarded',
     +           '     due to a termination for very small step in   ',
     +           '     the line search. A PSPG iteration will be     ',
     +           '     forced now.                                   '
            
            write(10,*)  
            write(10,*)  
     +           '     The previous Newtonian iteration was discarded',
     +           '     due to a termination for very small step in   ',
     +           '     the line search. A PSPG iteration will be     ',
     +           '     forced now.                                   '
         end if
         
         go to 200
      end if

      if (.not. gencan) then
         
C        If the inner BETRA algorithm stops declaring "first-order 
C        stationary point close to the boundary" (inform = 1) or 
C        "second-order stationary point" (inform = 2), but the 
C        projected discontinuous gradient is not null, use PSPG to leave the
C        current face.

         if ( ( inform .eq. 1 ) .or. ( inform .eq. 2 ) ) then
            
            if ( iprint .ge. 2 ) then
               write(*,*)  
               write(*,*)  
     +            '     No work needs to be done in the current face. ',
     +            '     A PSPG iteration will be forced now.          '
               
               write(10,*)  
               write(10,*)  
     +            '     No work needs to be done in the current face. ',
     +            '     A PSPG iteration will be forced now.          '
            end if
                  
            go to 200
         end if

C        If the inner BETRA algorithm stops because the trust-region 
C        radius became too small without obtaining sufficient decrease 
C        (inform = 5) then the main algorithm performes a global PSPG 
C        iteration.
      
         if ( inform .eq. 5 ) then
            
            if ( iprint .ge. 2 ) then
               write(*,*)  
               write(*,*)  
     +            '     Trust-region radius became too small. A PSPG  ',
     +            '     iteration will be forced now.                 '

               write(10,*)  
               write(10,*)  
     +            '     Trust-region radius became too small. A PSPG  ',
     +            '     iteration will be forced now.                 '
            end if
            
            go to 200
         end if

C        If the inner BETRA algorithm stops because the direction d
C        computed is such that x is too close to x + d (inform = 6) then 
C        the main algorithm performes a global PSPG iteration.

         if ( inform .eq. 6 ) then
            
            if ( iprint .ge. 2 ) then
               write(*,*)  
               write(*,*)  
     +            '     The direction computed in the previous        ',
     +            '     trust-region iteration was too small. A PSPG  ',
     +            '     iteration will be forced now.                 '
               
               write(10,*)  
               write(10,*)  
     +            '     The direction computed in the previous        ',
     +            '     trust-region iteration was too small. A PSPG  ',
     +            '     iteration will be forced now.                 '
            end if
            
            go to 200
         end if

      end if
        
      go to 300
          
 200  continue

      spgiter = spgiter + 1
      iter    = iter    + 1

C     Set iteration type

      ittype = 1

C     Compute spectral steplength
      
      if (.not. gotd) then
         if ( sty .le. 0.0d0 ) then
            lamspg = 1.0d0
         else
            lamspg = sts / sty
         end if
         lamspg = min( lspgma, max( lspgmi, lamspg ) )

         if (gotgp .and. (lamspg .eq. 1.0d0)) then
            do i = 1, n
               wd2(i) = wd1(i)
            end do
            
            gotd = .true.
         end if
      else
         if (maxstp .le. 0.1d0) then
            if (toldgptmp .lt. 1.0d+99) then
               toldgptmp = toldgptmp*1.0d2
            end if
         end if
      end if

C     Perform a line search with safeguarded quadratic interpolation 
C     along the direction of the spectral discontinuous projected gradient
      
      fcntprev = fcnt
      
      call pspgls(n,x,f,g,l,u,ml,mleq,lda,A,b,nact,iact,gotgp,tolact,
     +lamspg,etaint,mininterp,fmin,maxfc,iprint,wd1,stlen,gotd,wd2,
     +gamma,sigma1,sigma2,lossfeas,epscsn,projeps,promaxit,macheps,
     +toldgptmp,wi1,wd3,wd14,lwd14,wd15,wd4,fcnt,intnan,iterql,inform)
      
      spgfcnt   = spgfcnt + ( fcnt - fcntprev )
      
      if ( inform .ne. 6 ) then
         gotgp  = .false.
      end if
      
      if ( inform .lt. 0 ) then
         
         if ( iprint .ge. 2 ) then
            write(*, 1000) inform
            write(10,1000) inform
         end if
         
         return
      end if
      
      if ( inform .eq. 10 ) then
         
         if ( iprint .ge. 2 ) then
            write(*, 1012) inform
            write(10,1012) inform
         end if
         
         go to 500
      end if

C     Calculate wd14 = A x.
      
      do i = 1, ml
         wd14(i) = 0.0d0
      end do
      
      do j = 1, n
         do i = 1, ml
            wd14(i) = wd14(i) + A(i,j) * x(j)
         end do
      end do
      
C     Compute sup-norm of the linear constraits
      
      csupn = 0.0d0
      
      do i = 1, mleq
         csupn = max(csupn, abs(wd14(i) - b(i)))
      end do
      
      do i = mleq+1, ml
         csupn = max(csupn, b(i)-wd14(i))
      end do
      
C     Compute the gradient at the new iterate
      
      infotmp = inform
      
      call evalgr(n,x,g,gtype,macheps,inform)
      gcnt = gcnt + 1
      
      if ( inform .lt. 0 ) then
         
         if ( iprint .ge. 2 ) then
            write(*, 1000) inform
            write(10,1000) inform
         end if
         
         return
      end if

      inform = infotmp
          
C     Compute gradient Euclidian and Sup norms.
      
      gsupn = 0.0d0
      
      do i = 1, n
         gsupn = max(gsupn, abs(g(i)))
      end do
      
C     If gradient norm is smaller than eps, the norm of the
C     discontinuous-project-gradient is also smaller than eps. 
C     In this case, the algorithm stops.
      
      if (gsupn .le. epsgpsn) then
         
         gotgp = .true. 
         
C        Move all active linear constraints to the first rows of A.
C        Do the same with b. 
         
         do j = 1, n
            do i = mleq+1, nact
               ii = iact(i)
               
               if (i .ne. ii) then
                  tmp     = A(i,j)
                  A(i,j)  = A(ii,j)
                  A(ii,j) = tmp
               end if
            end do
         end do
         
         do i = mleq+1, nact
            ii = iact(i)
            
            if (i .ne. ii) then
               tmp   = b(i)
               b(i)  = b(ii)
               b(ii) = tmp
            end if
         end do
         
C        Change indices of active constraints.
              
         do i = mleq+1, nact
            iact(i) = i
         end do
         
         do i = nact+1, ml
            iact(i) = ml + nact + 1 - i
         end do
         
C        Move all "almost" active linear constraints to the first rows 
C        of A. Do the same with b.
      
         tolact = nact
         
         do i = nact+1, ml
            wd15(i) = 0.0d0
         end do
         
         do j = 1, n
            do i = nact+1, ml
               wd15(i) = wd15(i) + A(i,j) * x(j)
            end do
         end do
         
         do i = nact+1, ml
            ax = wd15(i)
            
            if (ax - b(i) .le. toldgptmp*max(1.0d0,abs(b(i)))) then
               
               tolact = tolact + 1
               ii     = tolact
               
               if (i .ne. ii) then
                  do j = 1, n
                     tmp     = A(i,j)
                     A(i,j)  = A(ii,j)
                     A(ii,j) = tmp
                  end do
                  
                  tmp   = b(i)
                  b(i)  = b(ii)
                  b(ii) = tmp
               end if
            end if
         end do
         
C        Use only active constraits to project
         
         do i = 1,n
            wd1(i) = x(i) - g(i)
         end do

         infotmp = inform
         
         call project(n, wd1, l, u, tolact, mleq, lda, A, b, promaxit, 
     +        projeps, lossfeas, epscsn, tmp, macheps, wi1, wd3, wd14, 
     +        lwd14, wd4, iterql, inform)

         if ((inform .lt. 0) .or. (inform .eq. 2)) then

            if ( iprint .ge. 2 ) then
               write(*,*)  
               write(*,*)  
     +            '     Problem in projection subroutine. Projected   ',
     +            '     gradient could not be calculated.             '
               
               write(10,*)  
               write(10,*)  
     +            '     Problem in projection subroutine. Projected   ',
     +            '     gradient could not be calculated.             '
            end if
            
            inform  = infotmp
            gpsupn  = 1.0d+99
            gpeucn2 = 1.0d+99
            
         else
            
            inform = infotmp
            
            do i = 1,n
               wd1(i) = wd1(i) - x(i)
            end do
            
C           Compute discontinuous-project-gradient Euclidian and Sup norms.
            
            gpsupn  = 0.0d0
            gpeucn2 = 0.0d0
            
            do i = 1, n
               gpsupn  = max(gpsupn, abs(wd1(i)))
               gpeucn2 = gpeucn2 + wd1(i)**2
            end do
         end if
         
C        Test whether the discontinuous-projected-gradient Sup norm is 
C        small enough to declare convergence
         
         if ( gpsupn .le. epsgpsn ) then
            inform = 0

            if ( iprint .ge. 2 ) then
               write(*, 991) inform,epsgpsn
               write(10,991) inform,epsgpsn
            end if
            
            go to 500
         end if
      end if      

 300  continue

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

C     This adjustment/projection is ''por lo que las putas pudiera''

      changed = .false.

      do i = 1,n
         if ( x(i) .le. l(i) + 
     +        macheps**(2.0d0/3.0d0) * max( abs( l(i) ), 1.0d0 ) ) then
            x(i)    = l(i)
            changed = .true.
         else if (x(i). ge. u(i) - 
     +        macheps**(2.0d0/3.0d0) * max( abs( u(i) ), 1.0d0 ) ) then  
            x(i)    = u(i)
            changed = .true.
         end if
      end do
      
C     Calculate wd14 = A x.

      if (changed) then
         do i = 1, ml
            wd14(i) = 0.0d0
         end do
         
         do j = 1, n
            do i = 1, ml
               wd14(i) = wd14(i) + A(i,j) * x(j)
            end do
         end do
      
C        Check if point x is feasible. Since the point calculated by the 
C        inner algorithm is feasible, it is not feasible if the adjustment 
C        of x made it infeasible. In this case, we set x as the point used 
C        in the begining of the iteration and begin another iteration 
C        asking for more precision in projection.
      
         csupn = 0.0d0
         
         do i = 1, mleq
            csupn = max(csupn, abs(wd14(i) - b(i)))
         end do
         
         do i = mleq+1, ml
            csupn = max(csupn, b(i)-wd14(i))
         end do

         if ((lossfeas .and. (csupn .gt. sqrt(epscsn))) .or.
     +        (.not. lossfeas .and. (csupn .gt. epscsn))) then
            
            if ( iprint .ge. 2 ) then
               write(*,*)  
               write(*,*)  
     +            '     Point became infeasible due to rounding. The  ',
     +            '     iteration will be restarted.                  '
               
               write(10,*)  
               write(10,*)  
     +            '     Point became infeasible due to rounding. The  ',
     +            '     iteration will be restarted.                  '
            end if

            do j = 1,n
               x(j) = xprev(j)
               g(j) = gprev(j)
            end do
            
            gotgp   = gotgpp
            projeps = projeps * 1.0d-02
            go to 110
         end if
      end if

C     Compute x Euclidian norm

      xeucn2 = 0.0d0
      xsupn = 0.0d0
      do i = 1,n
          xeucn2 = xeucn2 + x(i) ** 2
          xsupn = max( xsupn, abs( x(i) ) )
      end do

C     Compute s = x_{k+1} - x_k, y = g_{k+1} - g_k, <s,s> and <s,y>

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

C     If maximum step length was used, update list of free variables
C     and list of active linear constraints. The QR decomposition is
C     updated.

      if (inform .eq. 3) then

         samefa = .false.

C        If a bound is achieved, put its index in the end of the list
C        of free variables (from index nind2 + 1). 

         if (nact .eq. 0) then

            if (rbdlu .gt. 0) then

               k = 1
               
               index1 = rbdind(k)
               if (index1 .gt. n) then
                  index1 = index1 - n
               end if

               j = index1

               if (rbdlu .eq. 1) then
                  index2 = 0
               else
                  k = k + 1
                  index2 = rbdind(k)
                  if (index2 .gt. n) then
                     index2 = index2 - n
                  end if
               end if                 
                  
               do i = index1+1, nind
                  if (i .eq. index2) then
                     k = k + 1
                     if (k .gt. rbdlu) then
                        index2 = 0
                     else
                        index2 = rbdind(k)
                        if (index2 .gt. n) then
                           index2 = index2 - n
                        end if
                     end if
                  else
                     ind(j) = ind(i)
                     j = j + 1
                  end if
               end do
               
               nind = nind - rbdlu

               nind2 = nind
               do i = 1, nind2
                  ind2(i) = i
               end do
            end if 
         else
            
            if (rbdlu .gt. 0) then
               k = 1
               j = 1
               
               ii = rbdind(k)
               if (ii .gt. n) then
                  ii = ii - n
               end if
               index1 = ind(ii)
               
               do i = 1, nind2
                  ii = ind2(i)
                  
                  if (ind(ii) .eq. index1) then
                     k = k + 1
                     if (k .gt. rbdlu) then
                        index1 = 0
                     else
                        ii = rbdind(k)
                        if (ii .gt. n) then
                           ii = ii - n
                        end if
                        index1 = ind(ii)
                     end if
                  else
                     ind2(j) = ind2(i)
                     j = j + 1
                  end if
               end do
               
               nind2 = nind2 - rbdlu
               
               do k = 1, rbdlu
                  ii = rbdind(k)
                  if (ii .gt. n) then
                     ii = ii - n
                  end if
                  ind2(nind2+k) = ii
               end do
            end if
            
C           Update QR factorization of Abar for bounds that are 
C           attained, as if the bound were a linear constraint 
C           being added to active set.
            
            do k = 1, rbdlu
               
               if (nliact .ge. nind) then
                  go to 70
               end if              
               
               do i = 1, nind
                  wd3(i) = 0.0d0
               end do
               
               index1 = rbdind(k)
               if (index1 .gt. n) then
                  wd3(index1-n) = -1.0d0
               else
                  wd3(index1) = 1.0d0
               end if

               call updateQR(nind, nliact, ldabar, Abar, tau, wd3, wd4,
     +              macheps)
            end do
         end if
         
C        If a linear constraint is attained, remove its index1 from the 
C        list of inactive constraints (indices nact+1 to m of vector iact)
C        and insert it in the list of active constraints.

 70      if (rbdli .gt. rbdlu) then
         
            k = rbdind(rbdli)
            index1 = k
            rbdind(rbdli) = iact(index1)
            
            do i = 1, rbdli-rbdlu-1
               index2 = rbdind(rbdli-i)
               rbdind(rbdli-i) = iact(index2)
               
               do j = index1-1, index2+1, -1
                  iact(k) = iact(j)
                  k = k - 1
               end do
               
               index1 = index2
            end do
            
            index2 = nact
               
            do j = index1-1, index2 + 1, -1
               iact(k) = iact(j)
               k = k - 1 
            end do
               
            k = nact
            
            nact = nact + (rbdli - rbdlu)
            
            j = nact
            i = rbdlu+1
            ii = rbdind(i)
            
            do j = nact, 1, -1
               if ((k .lt. 1) .or. (ii .ge. iact(k))) then
                  iact(j) = ii
                  i = i + 1
                  
                  if (i .gt. rbdli) then
                     go to 80
                  end if
                  
                  ii = rbdind(i)
               else
                  iact(j) = iact(k)
                  k = k - 1
               end if
            end do
            
C           If linear constraints were attained, QR factorization 
C           of Abar is updated (or performed).
         
 80         if (nact .eq. (rbdli - rbdlu)) then
               do i = 1, nact
                  ii = iact(i)
                  do j = 1, nind
                     jj = ind(j)
                     Abar(j,i) = A(ii,jj)
                  end do
               end do
               
C              Calculate QR factorization of Abar.
               
               do i = 1, nact
                  wi1(i) = 0
               end do

               infotmp = inform
               
               call DGEQP3(nind, nact, Abar, ldabar, wi1, tau, wd14,
     +              lwd14, inform)

               if (inform .ne. 0) then
                  inform = -50
                  
                  if (iprint .ge. 2) then
                     write(*, 1010) inform
                     write(10,1010) inform
                  end if
                  
                  return
               end if

               inform = infotmp
               
C              Count the number of LI rows of Abar (that is, the number 
C              of non-null diagonal elements of R.
               
               k = min(nind, nact)
               nliact = 1
 3             if (abs(Abar(nliact,nliact)) .gt.
     +              macheps**(2.0d0/3.0d0)) then
                  nliact = nliact + 1
                  if (nliact .le. k) then
                     go to 3
                  end if
               end if
               
               nliact = nliact - 1
               
            else
               
               do k = rbdlu+1, rbdli

                  if (nliact .ge. nind) then
                     go to 90
                  end if
                  
                  index1 = rbdind(k)
                  
                  do i = 1, nind
                     ii = ind(i)
                     wd3(i) = A(index1,ii)
                  end do
                  
                  call updateQR(nind, nliact, ldabar, Abar, tau, wd3, 
     +                 wd4, macheps)
               end do
            
            end if
         end if
         
C     Recalculate the indices of free variables and active linear
C     constraints and perform QR decomposition.

      else if ((ittype .eq. 1) .or. (inform .eq. 4) .or. 
     +        (inform .eq. 8)) then
      
         samefa = .false.

C        Store in nind the number of free variables and in array ind
C        their identifiers.
         
         nind = 0
         do i = 1, n
            if ((x(i) .gt. l(i)) .and. (x(i) .lt. u(i))) then
               nind = nind + 1
               ind(nind) = i
            end if
         end do
         
         nind2 = nind
         do i = 1, nind2
            ind2(i) = i
         end do
         
C        Store in nact the number of active linear constraints and in
C        array iact their identifiers. The last m - nact positions of
C        iact store the identifier of the non-active linear constraints.
         
         nact = mleq
         k = ml
         
         do i = mleq+1, ml
            if (abs(wd14(i)-b(i)) .le. epscsn) then
               nact = nact + 1
               iact(nact) = i
            else
               iact(k) = i
               k = k - 1
            end if
         end do

C        If there is at least 1 active linear constraint, we need
C        to calculate matrix Z.
      
         if (nact .eq. 0) then
            nliact = 0
         else
            
C           Abar^T is formed by the columns of A corresponding to 
C           free variables and rows of A corresponding to active 
C           constraints.            

            do i = 1, nact
               ii = iact(i)
               do j = 1, nind
                  jj = ind(j)
                  Abar(j,i) = A(ii,jj)
               end do
            end do
            
C           Calculate QR factorization of Abar.

            do i = 1, nact
               wi1(i) = 0
            end do

            infotmp = inform
            
            call DGEQP3(nind, nact, Abar, ldabar, wi1, tau, wd14, lwd14,
     +           inform)

            if (inform .ne. 0) then
               inform = -50
               
               if (iprint .ge. 2) then
                  write(*, 1010) inform
                  write(10,1010) inform
               end if
               
               return
            end if

            inform = infotmp
            
C           Count the number of LI rows of Abar (that is, the number 
C           of non-null diagonal elements of R.

            k = min(nind, nact)
            nliact = 1
 5          if (abs(Abar(nliact,nliact)) .gt.
     +           macheps**(2.0d0/3.0d0)) then
               nliact = nliact + 1
               if (nliact .le. k) then
                  go to 5
               end if
            end if
            nliact = nliact - 1
         end if

      else

C        If neither a new constraint is attained nor a global PSPG 
C        iteration is performed, the new point belongs to the same face 
C        as the previous one.
         
         samefa = .true.
      end if

 90   continue
      
C     Print information of this iteration

      if ( iprint .ge. 2 ) then 
          write(*, 983) iter,ittext(ittype)
          write(*, 985) nprint,(x(i),  i=1,nprint)
          write(*, 986) nprint,(g(i),  i=1,nprint)
          if (gotgp) then
             write(*, 987) nprint,(wd1(i),i=1,nprint)
          end if
          write(*, 988) min0(nprint,nind2),nind2,(ind(ind2(i)),
     +    i=1,min0(nprint,nind2))
          write(*, 989) min0(mlprint,nact),nact,(iact(i),
     +    i=1,min0(mlprint,nact))
          if (gotgp) then
             if (ittype .eq. 1) then
                write(*, 1004) f,csupn,sqrt(gpeucn2),gpsupn,nind2,n,
     +               nact,ml,spgiter,tniter,ispgiter,triter,fcnt,gcnt,
     +               hcnt,cgcnt,chcnt
             else
                write(*, 1002) f,csupn,sqrt(gpeucn2),gpsupn,gzsupn,
     +               nind2,n,nact,ml,spgiter,tniter,ispgiter,triter,
     +               fcnt,gcnt,hcnt,cgcnt,chcnt
             end if
          else
             if (ittype .eq. 1) then
                write(*, 1003) f,csupn,nind2,n,nact,ml,spgiter,tniter,
     +               ispgiter,triter,fcnt,gcnt,hcnt,cgcnt,chcnt
             else
                write(*, 1001) f,csupn,gzsupn,nind2,n,nact,ml,spgiter,
     +               tniter,ispgiter,triter,fcnt,gcnt,hcnt,cgcnt,chcnt
             end if
          end if

          write(10,983) iter,ittext(ittype)
          write(10,985) nprint,(x(i),  i=1,nprint)
          write(10,986) nprint,(g(i),  i=1,nprint)
          if (gotgp) then
             write(10,987) nprint,(wd1(i),i=1,nprint)
          end if
          write(10,988) min0(nprint,nind2),nind2,(ind(ind2(i)),
     +    i=1,min0(nprint,nind2))
          write(10,989) min0(mlprint,nact),nact,(iact(i),
     +    i=1,min0(mlprint,nact))
          if (gotgp) then
             if (ittype .eq. 1) then
                write(10,1004) f,csupn,sqrt(gpeucn2),gpsupn,nind2,n,
     +               nact,ml,spgiter,tniter,ispgiter,triter,fcnt,gcnt,
     +               hcnt,cgcnt,chcnt
             else
                write(10,1002) f,csupn,sqrt(gpeucn2),gpsupn,gzsupn,
     +               nind2,n,nact,ml,spgiter,tniter,ispgiter,triter,
     +               fcnt,gcnt,hcnt,cgcnt,chcnt
             end if
          else
             if (ittype .eq. 1) then
                write(10,1003) f,csupn,nind2,n,nact,ml,spgiter,tniter,
     +               ispgiter,triter,fcnt,gcnt,hcnt,cgcnt,chcnt
             else
                write(10,1001) f,csupn,gzsupn,nind2,n,nact,ml,spgiter,
     +               tniter,ispgiter,triter,fcnt,gcnt,hcnt,cgcnt,chcnt
             end if
          end if
      end if

C     SAVING INTERMEDIATE DATA FOR CRASH REPORT

      open (20,file='genlin-tabline.out')
      write(20,3000) 0.0d0,99,n,ml,iter,fcnt,gcnt,hcnt,cgcnt,chcnt,
     +     spgiter,spgfcnt,tniter,tnfcnt,triter,trfcnt,ispgiter,
     +     ispgfcnt,iterql,f,csupn,gpsupn
      close(20)

C     If a boundary is hit, increase the counter hitbd. If this counter 
C     reached the maximum number (ktest), compute continuous-project-
C     gradient and verify if the solution is found. If current point is 
C     not the solution, compute internal discontinuous-project-gradient and
C     decide if the algorithm shoul stay in the current face. 

      if ( inform .eq. 3 ) then
         hitbd = hitbd + 1

         if ( hitbd .eq. ktest ) then
            hitbd = 0

C           Move all active linear constraints to the first rows of A.
C           Do the same with b. 
      
            do j = 1, n
               do i = mleq+1, nact
                  ii = iact(i)
                  
                  if (i .ne. ii) then
                     tmp     = A(i,j)
                     A(i,j)  = A(ii,j)
                     A(ii,j) = tmp
                  end if
               end do
            end do
            
            do i = mleq+1, nact
               ii = iact(i)
               
               if (i .ne. ii) then
                  tmp   = b(i)
                  b(i)  = b(ii)
                  b(ii) = tmp
               end if
            end do
         
C           Change indices of active constraints.
            
            do i = mleq+1, nact
               iact(i) = i
            end do
            
            do i = nact+1, ml
               iact(i) = ml + nact + 1 - i
            end do
            
C           Move all "almost" active linear constraints to the first rows 
C           of A. Do the same with b.
      
            tolact = nact
            
            do i = nact+1, ml
               wd15(i) = 0.0d0
            end do
            
            do j = 1, n
               do i = nact+1, ml
                  wd15(i) = wd15(i) + A(i,j) * x(j)
               end do
            end do
            
            do i = nact+1, ml
               ax = wd15(i)
               
               if (ax - b(i) .le. toldgptmp*max(1.0d0,abs(b(i)))) then
                  
                  tolact = tolact + 1
                  ii     = tolact
                  
                  if (i .ne. ii) then
                     do j = 1, n
                        tmp     = A(i,j)
                        A(i,j)  = A(ii,j)
                        A(ii,j) = tmp
                     end do
                     
                     tmp   = b(i)
                     b(i)  = b(ii)
                     b(ii) = tmp
                     
                     tmp      = wd15(i)
                     wd15(i)  = wd15(ii)
                     wd15(ii) = tmp
                  end if
               end if
            end do
         
C           Compute spectral steplength
            
            if ( sty .le. 0.0d0 ) then
               lamspg = 1.0d0
            else
               lamspg = sts / sty
            end if
            lamspg = min( lspgma, max( lspgmi, lamspg ) )
            
C           Use only active constraits to project
            
            do i = 1,n
               wd2(i) = x(i) - lamspg * g(i)
            end do

            infotmp = inform
            
            call project(n, wd2, l, u, tolact, mleq, lda, A, b, 
     +           promaxit, projeps, lossfeas, epscsn, tmp, macheps, wi1,
     +           wd3, wd14, lwd14, wd4, iterql, inform)
         
            if ((inform .lt. 0) .or. (inform .eq. 2)) then
               
               inform = -30
               
               if (iprint .ge. 2) then
                  write(*, 1007) inform
                  write(10,1007) inform
               end if
               
               return
            end if
            
            inform = infotmp
            
            do i = 1,n
               wd2(i) = wd2(i) - x(i)
            end do
            
C           Compute maximum step.

            do i = tolact+1, ml
               wd14(i) = 0.0d0
            end do
            
            do j = 1, n
               do i = tolact+1, ml
                  wd14(i) = wd14(i) + A(i,j) * wd2(j)
               end do
            end do
            
            maxstp = 1.0d0
            
            do i = tolact+1, ml
               ad = wd14(i)
               ax = wd15(i)
               
               if (ad .lt. 0.0d0) then
                  maxstp = min(maxstp, (b(i) - ax) / ad)
               end if
            end do
            
            do i = 1,n
               wd2(i) = maxstp * wd2(i)
            end do

C           Compute spectral-discontinuous-project-gradient Euclidian 
C           and Sup norms.
                
            sgpsupn = 0.0d0
            
            do i = 1, n
               sgpsupn = max(sgpsupn, abs(wd2(i)))
            end do
            
C           If spectral step is 1, both spectral-discontinuous-project-
C           gradient and discontinuous-project-gradient are the same.

            if (lamspg .eq. 1.0d0) then
               do i = 1, n
                  wd1(i) = wd2(i)/maxstp
               end do
               
               gpsupn = sgpsupn/maxstp
               gotgp  = .true.
               
C              Test whether the discontinuous-projected-gradient Sup norm
C              is small enough to declare convergence

               if ( gpsupn .le. epsgpsn ) then
                  inform = 0

                  if ( iprint .ge. 2 ) then
                     write(*, 991) inform,epsgpsn
                     write(10,991) inform,epsgpsn
                  end if
                  
                  go to 500
               end if
          
C              If the boundary of constraints is hit for ktest
C              consecutive iterations, perform a PSPG iteration

               if (iprint .ge. 2) then
                  write(*,*)  
                  write(*,*)  
     +            '     After hiting boundary of constraints ', ktest,
     +            '     times, the algorithm decided to leaves the',
     +            '     current face.'
                  
                  write(10,*)  
                  write(10,*)  
     +            '     After hiting boundary of constraints ', ktest,
     +            '     times, the algorithm decided to leaves the',
     +            '     current face.'
               end if
         
               gotd = .true.
               go to 200

C           If norm of spectral-discontinuous-project-gradient says the
C           current point is not a solution, perform a PSPG iteration to 
C           leave the current face, without computing the discontinuous
C           project-gradient.

            elseif (((lamspg .gt. 1.0d0) .and. 
     +              (sgpsupn/maxstp .ge. lamspg*epsgpsn)) .or.
     +              ((lamspg .lt. 1.0d0) .and. 
     +              (sgpsupn/maxstp .ge. epsgpsn))) then
            
               if (iprint .ge. 2) then
                  write(*,*)  
                  write(*,*)  
     +            '     After hiting boundary of constraints ', ktest,
     +            '     times, the algorithm decided to leaves the',
     +            '     current face.'
                  
                  write(10,*)  
                  write(10,*)  
     +            '     After hiting boundary of constraints ', ktest,
     +            '     times, the algorithm decided to leaves the',
     +            '     current face.'
               end if
               
               gotgp = .false.
               gotd  = .true.
               go to 200

C           If norm of spectral-discontinuous-project-gradient says the
C           current point is a solution, compute the discontinuous
C           project-gradient and stop the algorithm.

            elseif (((lamspg .gt. 1.0d0) .and. 
     +              (sgpsupn/maxstp .le. epsgpsn)) .or. 
     +              ((lamspg .lt. 1.0d0) .and. 
     +              (lamspg .ge. sqrt(macheps)) .and.
     +              (sgpsupn/maxstp .le. lamspg * epsgpsn))) then
               
               gotgp = .true.
               
               do i = 1,n
                  wd1(i) = x(i) - g(i)
               end do

               infotmp = inform
               
               call project(n, wd1, l, u, tolact, mleq, lda, A, b, 
     +              promaxit, projeps, lossfeas, epscsn, tmp, macheps,
     +              wi1, wd3, wd14, lwd14, wd4, iterql, inform)

               if ((inform .lt. 0) .or. (inform .eq. 2)) then
                  
                  if ( iprint .ge. 2 ) then
                     write(*,*)  
                     write(*,*)  
     +            '     Problem in projection subroutine. Projected   ',
     +            '     gradient could not be calculated.             '
               
                     write(10,*)  
                     write(10,*)  
     +            '     Problem in projection subroutine. Projected   ',
     +            '     gradient could not be calculated.             '
                  end if
                  
                  inform  = infotmp
                  gpsupn  = 1.0d+99
                  gpeucn2 = 1.0d+99
                  
               else
                  
                  inform = infotmp
                  
                  do i = 1,n
                     wd1(i) = wd1(i) - x(i)
                  end do
                  
C                 Compute discontinuous-project-gradient Euclidian
C                 and Sup norms.
                  
                  gpsupn  = 0.0d0
                  gpeucn2 = 0.0d0
                  
                  do i = 1, n
                     gpsupn  = max(gpsupn, abs(wd1(i)))
                     gpeucn2 = gpeucn2 + wd1(i)**2
                  end do
               end if
               
C              Test whether the discontinuous-projected-gradient Sup norm is 
C              small enough to declare convergence
         
               if ( sgpsupn/maxstp .le. epsgpsn ) then
                  inform = 0

                  if ( iprint .ge. 2 ) then
                     write(*, 991) inform,epsgpsn
                     write(10,991) inform,epsgpsn
                  end if
                  
                  go to 500
               end if

C              If the boundary of constraints is hit for ktest
C              consecutive iterations, perform a PSPG iteration

               if (iprint .ge. 2) then
                  write(*,*)  
                  write(*,*)  
     +            '     After hiting boundary of constraints ', ktest,
     +            '     times, the algorithm decided to leaves the',
     +            '     current face.'
                  
                  write(10,*)  
                  write(10,*)  
     +            '     After hiting boundary of constraints ', ktest,
     +            '     times, the algorithm decided to leaves the',
     +            '     current face.'
               end if
         
               gotd = .true.
               go to 200

C           If norm of spectral-discontinuous-project-gradient does not give 
C           any information about the norm of the discontinuous-project-
C           gradient, compute the latter and decide if the current point is 
C           a solution or if the algorithm should leave the current face.

            else
               
               gotgp = .true.
               
               do i = 1,n
                  wd1(i) = x(i) - g(i)
               end do

               infotmp = inform
               
               call project(n, wd1, l, u, tolact, mleq, lda, A, b, 
     +              promaxit, projeps, lossfeas, epscsn, tmp, macheps, 
     +              wi1, wd3, wd14, lwd14, wd4, iterql, inform)
               
               if ((inform .lt. 0) .or. (inform .eq. 2)) then
                  
                  inform = -30
                  
                  if (iprint .ge. 2) then
                     write(*, 1007) inform
                     write(10,1007) inform
                  end if
                  
                  return
               end if
               
               inform = infotmp
               
               do i = 1,n
                  wd1(i) = wd1(i) - x(i)
               end do
            
C              Compute discontinuous-project-gradient Euclidian 
C              and Sup norms.
            
               gpsupn  = 0.0d0
               gpeucn2 = 0.0d0
               
               do i = 1, n
                  gpsupn  = max(gpsupn, abs(wd1(i)))
                  gpeucn2 = gpeucn2 + wd1(i)**2
               end do
               
C              Test whether the discontinuous-projected-gradient Sup norm
C              is small enough to declare convergence

               if ( gpsupn .le. epsgpsn ) then
                  inform = 0

                  if ( iprint .ge. 2 ) then
                     write(*, 991) inform,epsgpsn
                     write(10,991) inform,epsgpsn
                  end if
                  
                  go to 500
               end if
               
C              If the boundary of constraints is hit for ktest
C              consecutive iterations, perform a PSPG iteration

               if (iprint .ge. 2) then
                  write(*,*)  
                  write(*,*)  
     +            '     After hiting boundary of constraints ', ktest,
     +            '     times, the algorithm decided to leaves the',
     +            '     current face.'
                  
                  write(10,*)  
                  write(10,*)  
     +            '     After hiting boundary of constraints ', ktest,
     +            '     times, the algorithm decided to leaves the',
     +            '     current face.'
               end if
         
               gotd = .true.
               go to 200
            end if
         end if
      else
         gotgp = .false.
         hitbd = 0
      end if

C     ==================================================================
C     Test some stopping criteria that may occur inside the line 
C     searches or trust-region algorithm
C     ==================================================================

      if ( ( inform .eq. 6 ) .and. ( ittype .eq. 1  ) ) then

          if ( iprint .ge. 2 ) then
              write(*, 996) inform,mininterp
              write(10,996) inform,mininterp
          end if

          go to 500

      end if

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

      go to 100

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

C     ==================================================================
C     Report output status and return
C     ==================================================================

 500  continue

C     Compute discontinuous-project-gradient gp = P(x - g) - x, if it has
C     not been calculated.

      if ( .not. gotgp ) then

C        Move all active linear constraints to the first rows of A.
C        Do the same with b. 
      
         do j = 1, n
            do i = mleq+1, nact
               ii = iact(i)
               
               if (i .ne. ii) then
                  tmp     = A(i,j)
                  A(i,j)  = A(ii,j)
                  A(ii,j) = tmp
               end if
            end do
         end do
         
         do i = mleq+1, nact
            ii = iact(i)
            
            if (i .ne. ii) then
               tmp   = b(i)
               b(i)  = b(ii)
               b(ii) = tmp
            end if
         end do
         
C        Change indices of active constraints.
      
         do i = mleq+1, nact
            iact(i) = i
         end do
         
         do i = nact+1, ml
            iact(i) = ml + nact + 1 - i
         end do
         
C        Move all "almost" active linear constraints to the first rows 
C        of A. Do the same with b.
      
         tolact = nact
         
         do i = nact+1, ml
            wd15(i) = 0.0d0
         end do
         
         do j = 1, n
            do i = nact+1, ml
               wd15(i) = wd15(i) + A(i,j) * x(j)
            end do
         end do

         do i = nact+1, ml
            ax = wd15(i)
            
            if (ax - b(i) .le. toldgptmp*max(1.0d0,abs(b(i)))) then
               
               tolact = tolact + 1
               ii     = tolact
               
               if (i .ne. ii) then
                  do j = 1, n
                     tmp     = A(i,j)
                     A(i,j)  = A(ii,j)
                     A(ii,j) = tmp
                  end do
                  
                  tmp   = b(i)
                  b(i)  = b(ii)
                  b(ii) = tmp
               end if
            end if
         end do
         
C        Use only active constraits to project

         do i = 1,n
            wd1(i) = x(i) - g(i)
         end do

         infotmp = inform

         call project(n, wd1, l, u, tolact, mleq, lda, A, b, promaxit, 
     +        projeps, lossfeas, epscsn, tmp, macheps, wi1, wd3, wd14, 
     +        lwd14, wd4, iterql, inform)
         
         if ((inform .lt. 0) .or. (inform .eq. 2)) then

            if ( iprint .ge. 2 ) then
               write(*,*)  
               write(*,*)  
     +            '     Problem in projection subroutine. Projected   ',
     +            '     gradient could not be calculated.             '
               
               write(10,*)  
               write(10,*)  
     +            '     Problem in projection subroutine. Projected   ',
     +            '     gradient could not be calculated.             '
            end if
            
            inform = infotmp
            gpsupn  = 1.0d+99
            gpeucn2 = 1.0d+99

         else
         
            inform = infotmp

            do i = 1,n
               wd1(i) = wd1(i) - x(i)
            end do

C           Compute discontinuous-project-gradient Euclidian and Sup norms.
            
            gpsupn  = 0.0d0
            gpeucn2 = 0.0d0
            
            do i = 1, n
               gpsupn  = max(gpsupn, abs(wd1(i)))
               gpeucn2 = gpeucn2 + wd1(i)**2
            end do
         end if
      end if

C     Print final information

      if ( iprint .ge. 2 ) then
          write(*, 982) iter
          write(*, 985) nprint,(x(i),  i=1,nprint)
          write(*, 986) nprint,(g(i),  i=1,nprint)
          write(*, 987) nprint,(wd1(i),i=1,nprint)
          write(*, 988) min0(nprint,nind2),nind2,(ind(ind2(i)),
     +    i=1,min0(nprint,nind2))
          write(*, 989) min0(mlprint,nact),nact,(iact(i),
     +    i=1,min0(mlprint,nact))
          if (ittype .eq. 1) then
             write(*, 1004) f,csupn,sqrt(gpeucn2),gpsupn,nind2,n,nact,
     +            ml,spgiter,tniter,ispgiter,triter,fcnt,gcnt,hcnt,
     +            cgcnt,chcnt
          else
             write(*, 1002) f,csupn,sqrt(gpeucn2),gpsupn,gzsupn,nind2,n,
     +            nact,ml,spgiter,tniter,ispgiter,triter,fcnt,gcnt,hcnt,
     +            cgcnt,chcnt
          end if

          write(10,982) iter
          write(10,985) nprint,(x(i),  i=1,nprint)
          write(10,986) nprint,(g(i),  i=1,nprint)
          write(10,987) nprint,(wd1(i),i=1,nprint)
          write(10,988) min0(nprint,nind2),nind2,(ind(ind2(i)),
     +    i=1,min0(nprint,nind2))
          write(10,989) min0(mlprint,nact),nact,(iact(i),
     +    i=1,min0(mlprint,nact))
          if (ittype .eq. 1) then
             write(10,1004) f,csupn,sqrt(gpeucn2),gpsupn,nind2,n,nact,
     +            ml,spgiter,tniter,ispgiter,triter,fcnt,gcnt,hcnt,
     +            cgcnt,chcnt
          else
             write(10,1002) f,csupn,sqrt(gpeucn2),gpsupn,gzsupn,nind2,n,
     +            nact,ml,spgiter,tniter,ispgiter,triter,fcnt,gcnt,hcnt,
     +            cgcnt,chcnt
          end if
      end if

C     Non-executable statements

 973  format(/1X,'Entry to GENLIN. Number of variables: ',I6)
 974  format(/1X,'Number of linear constraints: ',I6)
 975  format(/1X,'Coefficients of linear constraints (first ',
     +I6, ' constraints): ')
 976  format(/1X, '(first ',I6, ' components): ',/,6(1X,1PD11.4))
 977  format(/1X,'Right-hand side of linear constraints (first ',
     +I6, ' components): ',/,6(1X,1PD11.4)) 
 978  format(/1X,'Lower bounds (first ',I6, ' components): ',
     +/,6(1X,1PD11.4))
 979  format(/1X,'Upper bounds (first ',I6, ' components): ',
     +/,6(1X,1PD11.4))
 980  format(/1X,'Initial point (first ',I6, ' components): ',
     +/,6(1X,1PD11.4))
 981  format(/1X,'GENLIN iteration: ',I6,' (Initial point)')
 982  format(/1X,'GENLIN iteration: ',I6,' (Final point)')
 983  format(/1X,'GENLIN iteration: ',I6,1X,A41)
 985  format(1X,'Current point (first ',I6, ' components): ',
     +/,6(1X,1PD11.4))
 986  format(1X,'Current gradient (first ',I6, ' components): ',
     +/,6(1X,1PD11.4))
 987  format(1X,'Current discontinuous projected gradient (first ',I6, 
     +' components): ',/,6(1X,1PD11.4))
 988  format(1X,'Current free variables (first ',I6,
     +', total number ',I6,'): ',/,10(1X,I6))
 989  format(1X,'Current active linear constraints (first ',I6,
     +', total number ',I6,'): ',/,10(1X,I6))      
 991  format(/1X,'Flag of GENLIN = ',I3,
     +' (convergence with sup-norm of the projected gradient',
     +/,1X,'smaller than ',1PD11.4,')')
 992  format(/1X,'Flag of GENLIN = ',I3,
     +' (The algorithm stopped by lack of enough progress. This means',
     +/,1X,'that  f(x_k) - f(x_{k+1}) .le. ',1PD11.4,
     +' * max [ f(x_j)-f(x_{j+1}, j < k ]',/,1X,'during ',I7,
     +' consecutive iterations)')
 994  format(/1X,'Flag of GENLIN = ',I3,
     +' (The algorithm stopped because the functional value is',
     +/,1X,'smaller than ',1PD11.4,')')
 996  format(/1X,'Flag of GENLIN = ',I3,
     +' (After having made at least ',I7,' interpolations, the',/,
     +' line search step became very small)')
 997  format(/1X,'Flag of GENLIN = ',I3,
     +' (It exceeded the maximum allowed number of iterations',
     +/,1X,'(maxit=',I7,')')
 998  format(/1X,'Flag of GENLIN = ',I3,
     +' (It exceeded the maximum allowed number of functional',
     +/,1X,'evaluations (maxfc=',I7,')')
 1001 format(1X,'Functional value: ', 1PD11.4,
     +/,1X,'Sup-norm of the linear constraints: ',1PD11.4, 
     +/,1X,'Sup-norm internal gradient: ',1PD11.4,
     +/,1X,'Free variables at this point: ',I7,
     +' (over a total of ',I7,')',
     +/,1X,'Active linear constraints at this point: ',I7,
     +' (over a total of ',I7,')',
     +/,1X,'PSPG iterations: ',I7,
     +/,1X,'TN iterations: ',I7,
     +/,1X,'inner SPG iterations: ',I7,
     +/,1X,'Trust-region iterations: ', I7,
     +/,1X,'Functional evaluations: ',I7,
     +/,1X,'Gradient evaluations: ',I7,
     +/,1X,'Hessian evaluations: ',I7,      
     +/,1X,'Conjugate gradient iterations: ',I7,
     +/,1X,'Cholesky decompositions: ', I7)
 1002 format(1X,'Functional value: ', 1PD11.4,
     +/,1X,'Sup-norm of the linear constraints: ',1PD11.4, 
     +/,1X,'Euclidian-norm of the discontinuous projected gradient: ',
     +1PD11.4,
     +/,1X,'Sup-norm of the discontinuous projected gradient: ',1PD11.4,
     +/,1X,'Sup-norm internal gradient: ',1PD11.4,
     +/,1X,'Free variables at this point: ',I7,
     +' (over a total of ',I7,')',
     +/,1X,'Active linear constraints at this point: ',I7,
     +' (over a total of ',I7,')',
     +/,1X,'PSPG iterations: ',I7,
     +/,1X,'TN iterations: ',I7,
     +/,1X,'inner SPG iterations: ',I7,
     +/,1X,'Trust-region iterations: ', I7,
     +/,1X,'Functional evaluations: ',I7,
     +/,1X,'Gradient evaluations: ',I7,
     +/,1X,'Hessian evaluations: ',I7,      
     +/,1X,'Conjugate gradient iterations: ',I7,
     +/,1X,'Cholesky decompositions: ', I7)
 1003 format(1X,'Functional value: ', 1PD11.4,
     +/,1X,'Sup-norm of the linear constraints: ',1PD11.4, 
     +/,1X,'Free variables at this point: ',I7,
     +' (over a total of ',I7,')',
     +/,1X,'Active linear constraints at this point: ',I7,
     +' (over a total of ',I7,')',
     +/,1X,'PSPG iterations: ',I7,
     +/,1X,'TN iterations: ',I7,
     +/,1X,'inner SPG iterations: ',I7,
     +/,1X,'Trust-region iterations: ', I7,
     +/,1X,'Functional evaluations: ',I7,
     +/,1X,'Gradient evaluations: ',I7,
     +/,1X,'Hessian evaluations: ',I7,      
     +/,1X,'Conjugate gradient iterations: ',I7,
     +/,1X,'Cholesky decompositions: ', I7)
 1004 format(1X,'Functional value: ', 1PD11.4,
     +/,1X,'Sup-norm of the linear constraints: ',1PD11.4, 
     +/,1X,'Euclidian-norm of the discontinuous projected gradient: ',
     +1PD11.4,
     +/,1X,'Sup-norm of the discontinuous projected gradient: ',1PD11.4,
     +/,1X,'Free variables at this point: ',I7,
     +' (over a total of ',I7,')',
     +/,1X,'Active linear constraints at this point: ',I7,
     +' (over a total of ',I7,')',
     +/,1X,'PSPG iterations: ',I7,
     +/,1X,'TN iterations: ',I7,
     +/,1X,'inner SPG iterations: ',I7,
     +/,1X,'Trust-region iterations: ', I7,
     +/,1X,'Functional evaluations: ',I7,
     +/,1X,'Gradient evaluations: ',I7,
     +/,1X,'Hessian evaluations: ',I7,      
     +/,1X,'Conjugate gradient iterations: ',I7,
     +/,1X,'Cholesky decompositions: ', I7)
 1007 format(/1X,'Flag of GENLIN = ',I3,
     +     ' (Problem in projection routine)')
 1008 format(/1X,'Flag of GENLIN = ',I3,
     +     ' (Constraint ', I3, ' is inconsistent)')
 1009 format(/1X,'Flag of GENLIN = ',I3,
     +     ' (Problem in projection routine. Point is infeasible)')
 1010 format(/1X,'Flag of GENLIN = ',I3,
     +     ' (Error in QR decomposition)')
 1011 format(/1X,'Flag of GENLIN = ',I3,
     +     ' (The algorithm stopped because the point is infeasible.',
     +     /,1X,'Linear constraint ',I3,' is not satisfied)') 
 1012 format(/1X,'Flag of GENLIN = ',I3,
     +     ' (The algorithm stopped because a feasible direction ',
     +     ' could not be computed)')
 1000 format(/1X,'Flag of GENLIN = ',I3,' Fatal Error')
 3000 format(F8.2,1X,I3,1X,I6,1X,I6,1X,I7,1X,I7,1X,I7,1X,I7,1X,I10,1X,
     +       I10,1X,I10,1X,I10,1X,I10,1X,I10,1X,I10,1X,I10,1X,I10,1X,
     +       I10,1X,I10,1X,1P,D24.16,1X,1P,D7.1,1X,1P,D7.1)
      end

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

      subroutine wfgencan(n, nind, ind, nind2, ind2, x, l, u, ml, mleq, 
     +     lda, A, b, f, g, gz, nact, nliact, iact, ldabar, Abar, tau, 
     +     iter, xsupn, xeucn2, gotgp, gpsupn, gpeucn2, s, y, ssupn, 
     +     seucn, yeucn, sts, sty, gtype, hptype, trtype, precond, 
     +     iprint, ncomp, cgepsf, cgepsi, cgscre, acgeps, bcgeps, 
     +     delmin, ucgmia, ucgmib, udelta0, epsnqmp, maxitnqmp, theta, 
     +     lossfeas, epscsn, macheps, bignum, samefa, lspgmi, lspgma, 
     +     etaint, mininterp, fmin, maxfc, gamma, sigma1, sigma2, d, dz, 
     +     wi1, wd1, wd2, wd3, wd4, wd5, wd6, wd7, wd8, wd9, wd10, wd11, 
     +     wd12, wd13, wd14, ittype, rbdlu, rbdli, rbdind, fcnt, gcnt, 
     +     hcnt, cgcnt, tniter, tnfcnt, tnstpcnt, tnintcnt, tnintfe, 
     +     inform)

C     SCALAR ARGUMENTS
      logical lossfeas, samefa, gotgp
      character * 6 precond, aptype
      integer n, nind, nind2, ml, mleq, lda, nact, nliact, ldabar, iter,
     +     gtype, hptype, trtype, iprint, ncomp, cgscre, maxitnqmp, 
     +     mininterp, maxfc, ittype, rbdlu, rbdli, fcnt, gcnt, hcnt, 
     +     cgcnt, tniter, tnfcnt, tnstpcnt, tnintcnt, tnintfe, inform
      double precision f, xsupn, xeucn2, gpsupn, gpeucn2, ssupn, seucn, 
     +     yeucn, sts, sty, cgepsf, cgepsi, acgeps, bcgeps, delmin, 
     +     ucgmia, ucgmib, udelta0, epsnqmp, theta, epscsn, macheps, 
     +     bignum, lspgmi, lspgma, etaint, fmin, gamma, sigma1, sigma2

C     ARRAY ARGUMENTS
      integer ind(nind), ind2(nind), iact(ml), rbdind(n+ml), wi1(2*n+ml)
      double precision x(n), l(n), u(n), A(lda,n), b(ml), g(n), 
     +     gz(nind-nliact), Abar(ldabar,nliact), tau(nliact), s(n), 
     +     y(n), d(n), dz(nind-nliact), wd1(n), wd2(n), wd3(n), wd4(n), 
     +     wd5(n), wd6(n), wd7(n), wd8(n), wd9(n), wd10(n), wd11(n), 
     +     wd12(n), wd13(n), wd14(ml)

C     Solves the "unconstrained" minimization subproblem
C
C                         Minimize f(x)
C
C     using a 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
C     Description of WFGENCAN arguments:
C
C     On Entry
C
C     n        integer 
C              number of variables
C
C     nind     integer
C              dimension of reduced space
C
C     ind      integer ind(nind)
C              indices of free variables, including bounds that were 
C              added to the active set and treated as linear constraints 
C              to update the basis of the null space of the linear
C              constraints
C
C     nind2    integer
C              dimension of reduced space
C
C     ind2     integer ind2(nind2)
C              indices of the truely free variables
C
C     x        double precision x(n)
C              initial estimation of the solution
C
C     l        double precision l(n)
C              lower bounds on the variables
C
C     u        double precision u(n)
C              upper bounds on the variables
C
C     ml       integer
C              total number of linear constraints (excluding bounds)
C
C     mleq     integer
C              number of linear equality constraints (excluding bounds)     
C      
C     lda      integer
C              leading dimension of matrix A
C      
C     A        double precision A(lda,n)
C              coeficients of linear constraints
C
C     b        double precision b(ml)
C              constant part of linear constraints
C
C     f        double precision
C              function value at x
C
C     g        double precision g(n)
C              gradient at x
C
C     gz       double precision gz(nind-nliact)
C              reduced gradient at x (Z^T g)
C
C     nact     integer
C              number of active linear constraints
C
C     nliact   integer
C              number of linearly independent active linear
C              constraints
C
C     iact     integer iact(ml)
C              indices of the active linear constraints. The last 
C              m - nact positions of iact store the identifier of the 
C              non-active linear constraints.
C
C     ldabar   integer
C              leading dimension of matrix Abar
C
C     Abar     double precision Abar(ldabar,nliact)
C              hold the LQ factorization of the matrix whose columns
C              correspond to the active linear constraints, after 
C              eliminating the elements correnponding to fixed variables
C
C     tau      double precision tau(nliact)
C              used to retrieve the columns of Q from Abar
C
C     iter     integer
C              current linearly-constrained minimization iteration
C
C     xsupn    double precision
C              x infinity norm
C
C     xeucn2   double precision
C              squared x Euclidian norm
C
C     gotgp    logical
C              true iff projected gradient at x was calculated
C
C     gpsupn   double precision
C              sup-norm of the continuous projected gradient at the 
C              final estimation
C
C     gpeucn2  double precision
C              squared euclidian-norm of the continuous projected 
C              gradient at the final estimation
C
C     s        double precision s(n)
C              diference between x and initial point from previous 
C              iteration
C
C     y        double precision y(n)
C              diference between g and the grandient of the initial 
C              point from previous iteration
C
C     ssupn    double precision
C              s infinity norm
C
C     seucn    double precision
C              s Euclidian norm
C
C     yeucn    double precision
C              s Euclidian norm
C
C     sts      double precision
C              scalar product between s and s
C
C     sty      double precision
C              scalar product between s and y
C
C     gtype    integer
C              gtype indicates in which way the gradient of the 
C              objective function will be computed. See the detailed
C              description of this parameter in subroutine param.
C
C              RECOMMENDED: gtype = 0
C
C              CONSTRAINTS: allowed values are just 0 or 1.
C
C     hptype   integer
C              hptype indicates in which way the Hessian (or the matrix-
C              vector product) will be approximated. See the detailed
C              description of this parameter in subroutine param.
C 
C              RECOMMENDED: hptype = 0
C
C              CONSTRAINTS: any value from 0 to 6 and 9.
C
C     trtype   integer
C              Type of Conjugate Gradients ''trust-radius''. trtype 
C              equal to 0 means Euclidian-norm trust-radius and trtype 
C              equal to 1 means sup-norm trust radius
C
C              RECOMMENDED: trtype = 0
C
C              CONSTRAINTS: allowed values are just 0 or 1.
C
C     precond  character * 6
C              indicates the type of preconditioning that will be used
C              for Conjugates Gradients.
C
C              'NONE'   means no preconditioner at all,
C
C              'QNCGNA' means Quasi-Newton Correction of the Gauss-
C                       Newton approximation of the Hessian. The exact
C                       form is this preconditioner is described in:
C 
C                       E. G. Birgin and J. M. Martínez, "Structured 
C                       minimal-memory inexact quasi-Newton method and 
C                       secant preconditioners for Augmented Lagrangian 
C                       Optimization", Computational Optimization and 
C                       Applications, 39, pp, 1-16, 2008.
C
C     iprint   integer
C              Commands printing. Nothing is printed if iprint is 
C              smaller than 2. If iprint is greater than or equal to 
C              2, WFGENCAN iterations information is printed. If 
C              iprint is greater than or equal to 3, line searches  
C              and Conjugate Gradients information is printed.
C
C              RECOMMENDED: iprint = 2
C
C              CONSTRAINTS: allowed values are just 2 or 3.
C
C     ncomp    integer
C              This constant is just for printing. In a detailed 
C              printing option, ncomp components of some vectors will
C              be printed
C
C              RECOMMENDED: ncomp = 5
C
C              CONSTRAINTS: ncomp >= 0
C
C     cgepsf   double precision
C              See below
C
C     cgepsi   double precision
C              small positive numbers for declaring convergence of the 
C              Conjugate Gradients subalgorithm when ||r||_2 < cgeps * 
C              ||rhs||_2, where r is the residual and rhs is the right 
C              hand side of the linear system, i.e., CG stops when the 
C              relative error of the solution is smaller than cgeps. 
C
C              cgeps varies from cgepsi to cgepsf in a way that depends 
C              on cgscre as follows:
C
C              i) CASE cgscre = 1: log10(cgeps^2) depends linearly on 
C              log10(||g_P(x)||_2^2) which varies from ||g_P(x_0)||_2^2 
C              to epsgpen^2
C
C              ii)  CASE cgscre = 2: log10(cgeps) depends linearly on 
C              log10(||g_P(x)||_inf) which varies from ||g_P(x_0)||_inf 
C              to epsgpsn
C
C              RECOMMENDED: cgepsi = 1.0d-01, cgepsf = 1.0d-05
C
C              CONSTRAINTS: cgepsi >= cgepsf >= 0.0
C
C     cgscre   integer
C              cgscre means conjugate gradient stopping criterion 
C              relation. It is related to a stopping criterion of
C              Conjugate Gradients. This stopping criterion depends on 
C              the norm of the residual of the linear system. The norm 
C              of the residual should be less or equal than a ''small''
C              quantity which decreases as we are approximating the
C              solution of the minimization problem (near the solution,
C              better the truncated-Newton direction we aim). Then, the
C              log of the required accuracy requested to Conjugate
C              Gradient has a linear dependence on the log of the norm
C              of the projected gradient. This linear relation uses the
C              squared Euclidian norm of the projected gradient if
C              cgscre is equal to 1 and uses the sup-norm if cgscre is
C              equal to 2.
C
C              RECOMMENDED: cgscre = 2
C
C              CONSTRAINTS:  allowed values for cgscre are just 1 or 2
C
C     acgeps   double precision
C              see below
C      
C     bcgeps   double precision
C               used to introduce linear relation between gpeucn2 and
C               cgeps2, i.e., scalars acgeps and bcgeps such that 
C
C               acgeps*log10(||g_P(x_0)||_2^2) + bcgeps = log10(cgeps_0^2)
C
C               acgeps*log10(||g_P(x_f)||_2^2) + bcgeps = log10(cgeps_f^2),
C
C               where cgeps_0 and cgeps_f are provided
C
C     delmin   double precision
C              Smaller Conjugate Gradients ''trust radius'' to compute 
C              the Truncated Newton direction
C
C              RECOMMENDED: delmin = 0.1
C
C              CONSTRAINTS: delmin > 0.0
C
C     ucgmia   double precision
C              see below
C
C     ucgmib   double precision
C              the maximum allowed number of iterations for each run of 
C              the Conjugate Gradient subalgorithm will be 
C
C              max( 1, int( ucgmia * nind + ucgmib ) ),
C
C              where nind is the number of variables of the subproblem.
C
C              The default value for this maximum number of CG iterations
C              is a linear function of the projected gradient sup-norm.
C              It goes from max( 1, 10 * log( nind ) ) when the method is
C              far from the solution to nind when the method is near to 
C              the solution, where nind is the number of variables of the 
C              subproblem (equal to the number of free variables). 
C
C              The default value will be used if the user sets ucgmia or 
C              ucgmib to any non-positive value. 
C
C              RECOMMENDED: ucgmia = - 1 and ucgmib = - 1
C
C              CONSTRAINTS: there are no constraints for this argument
C
C     udelta0  double precision
C              initial ''trust-radius'' for Conjugate Gradients. The 
C              default value max( delmin, 0.1 * max( 1, ||x|| ) ) is 
C              used if the user sets udelta0 <= 0. 
C
C              RECOMMENDED: udelta0 = - 1.0
C
C              CONSTRAINTS: there are no constraints for this argument
C
C     epsnqmp  double precision
C              See below
C
C     maxitnqmp integer
C              This and the previous argument are used for a stopping 
C              criterion of the Conjugate Gradients subalgorithm. If the 
C              progress in the quadratic model is smaller than fraction 
C              of the best progress ( epsnqmp * bestprog ) during 
C              maxitnqmp consecutive iterations then CG is stopped 
C              declaring ''not enough progress of the quadratic model''.
C
C              RECOMMENDED: epsnqmp = 1.0d-04, maxitnqmp = 5
C
C              CONSTRAINTS: epsnqmp >= 0.0, maxitnqmp >= 1.
C
C     theta    double precision
C              Constant for the angle condition, i.e., at iteration k we 
C              need a direction dk such that <gk,dk> <= - theta 
C              ||gk||_2 ||dk||_2, where gk is \nabla f(xk)
C
C              RECOMMENDED: theta = 10^{-6}
C
C              CONSTRAINTS: 0.0 < theta < 1.0
C
C     lossfeas logical
C              if a loss of feasibility up to sqrt(epsfeas) is allowed
C              during the computations, lossfeas must be set to TRUE
C              (recommended). In this case, if the final iterate does
C              not satisfy the constraints with the desired precision,
C              we sugest that the user re-run the method using the final
C              point obtained as the initial point, using
C              lossfeas = FALSE
C
C              RECOMMENDED: lossfeas = TRUE
C
C     epscsn   double precision
C              feasibility tolerance for the sup-norm of the linear
C              constraints
C     
C              RECOMMENDED: epscsn = 10^{-8}
C
C              CONSTRAINTS: epscsn > 0.0
C
C     macheps  double precision
C              macheps is the smallest positive number such that
C              1 + macheps is not equal to 1
C
C     bignum   double precision
C              a big number, like 10^{99}
C
C     samefa   logical
C              true iff current point is in the same face as the 
C              previous one
C
C     lspgmi   double precision
C              See below
C
C     lspgma   double precision
C              The spectral steplength, called lamspg, is projected onto 
C              the box [lspgmi,lspgma] 
C
C              RECOMMENDED: lspgmi = 1.0d-10 and lspgma = 1.0d+10
C 
C              CONSTRAINTS: lspgma >= lspgmi > 0.0
C
C     etaint   double precision
C              Constant for the interpolation. See the description of 
C              sigma1 and sigma2 above. Sometimes, in a line search, we 
C              take the new trial step as the previous one divided by 
C              etaint
C
C              RECOMMENDED: etaint = 2.0
C
C              CONSTRAINTS: etaint > 1.0.
C
C     mininterp integer
C              Constant for testing if, after having made at least 
C              mininterp interpolations, the steplength is too small. In
C              that case, failure of the line search is declared (may be 
C              the direction is not a descent direction due to an error 
C              in the gradient calculations). Use mininterp greater 
C              than or equal to maxfc for inhibit this stopping 
C              criterion
C
C              RECOMMENDED: mininterp = 4 
C
C              CONSTRAINTS: mininterp >= 1
C
C     fmin     double precision
C              function value for the stopping criteria f <= fmin
C
C              There is a stopping criterion that stops WFGENCAN if a 
C              point with a functional value smaller than fmin is found. 
C              The idea behind this stopping criterion is to stop the 
C              method if the objective function is not bounded from 
C              bellow.
C
C              RECOMMENDED: fmin = - bignum
C
C              CONSTRAINTS: there are no constraints for this argument
C
C     maxfc    integer
C              maximum allowed number of functional evaluations
C
C              RECOMMENDED: maxfc = 5 * maxit
C
C              CONSTRAINTS: maxfc >= 1
C
C
C     gamma    double precision
C              Constant for the Armijo criterion
C              f(x + alpha d) <= f(x) + gamma * alpha * <g,d>
C
C              RECOMMENDED: gamma = 1.0d-04
C
C              CONSTRAINTS: 0.0 < gamma < 0.5.
C
C     sigma1   double precision
C              See below
C
C     sigma2   double precision
C              Constant for the safeguarded interpolation. If alpha_new 
C              is not inside the interval [sigma1, sigma * alpha] then 
C              we take alpha_new = alpha / etaint
C
C              RECOMMENDED: sigma1 = 0.1 and sigma2 = 0.9
C
C              CONSTRAINTS: 0 < sigma1 < sigma2 < 1.
C
C     d        double precision d(n)
C     dz       double precision dz(nind-nliact)
C     wd1,...,wd13 double precision wd1,..,wd13(n)
C     wd14     double precision wd14(ml)
C              working vectors
C
C     On Return
C
C     x        double precision x(n)
C              final estimation to the solution within the face
C
C     f        double precision
C              function value at the final estimation 
C
C     g        double precision g(n)
C              gradient at the final estimation
C
C     ittype   integer
C              iteration type. Set to 2-6 to mean truncated-Newton
C
C     rbdlu    integer
C              number of variables that reached a lower or upper 
C              bound
C
C     rbdli    integer
C              total number of new active constraints. rbdli-rbdlu
C              is the number of linear constraints that are now 
C              satisfied by equality
C
C     rbdind   integer rbdind(n+ml)
C              indices of bound and linear constraints that are 
C              satisfied by equality at the new point x. That is, 
C              indices of the constraints to be added to the active set)
C
C     fcnt     integer
C              number of function evaluations   
C
C     gcnt     integer
C              number of gradient evaluations   
C
C     hcnt     integer
C              number of hessian evaluations   
C
C     cgcnt    integer
C              number of Conjugate Gradients iterations   
C
C     tniter   integer
C              number of Truncated-Newton iterations
C
C     tnfcnt   integer
C              number of functional evaluations along Truncated-Newton
C              directions
C
C     tnstpcnt integer
C              number of times the Newton point was accepted (without
C              interpolations nor extrapolations)
C
C     tnintcnt integer
C              number of times a backtracking in a Truncated-Newton
C              direction was needed
C
C     tnintfe  integer
C              number of functional evaluations used in interpolations 
C              along Truncated-Newton directions
C
C     inform   integer
C              This output parameter tells what happened in this 
C              subroutine, according to the following conventions:
C 
C              0 = convergence with an Armijo-like criterion
C                  (f(xnew) <= f(x) + 1.0d-4 * alpha * <g,d>);
C
C              3 = new point x is in the boundary of the current face;
C
C              4 = the algorithm stopped because the functional value 
C                  is very small (smaller than fmin). If desired, set 
C                  fmin equal to minus bignum to inhibit this stopping 
C                  criterion;
C
C              6 = too small step in a line search. After having made at 
C                  least mininterp interpolations, the steplength 
C                  becames small. ''small steplength'' means that we are 
C                  at point x with direction d and step alpha, such that
C
C                  | alpha * d(i) | <= macheps * max( | x(i) |, 1 ) 
C
C                  for all i.
C
C                  In that case failure of the line search is declared 
C                  (may be the direction is not a descent direction due 
C                  to an error in the gradient calculations). If 
C                  desired, set mininterp equal to maxfc to inhibit this 
C                  stopping criterion;
C
C              8 = it was achieved the maximum allowed number of 
C                  function evaluations (maxfc);
C
C             10 = new point x+alpha*d would be infeasible, so x is 
C                  returned;
C
C            -90 = means that subroutine evalf retuned an error flag;
C
C            -92 = means that subroutine evalg retuned an error flag;
C
C            -94 = means that subroutine evalh retuned an error flag.

C     LOCAL SCALARS
      integer i, ii, j, jj, jjj, cgmaxit, cgiter, tnintprev, fcntprev
      double precision delta, amax, amaxx, cgeps, ax, ad 
      
      if (iprint .ge. 3) then
         write(*, 990)
         write(10,990)
      end if
      
      tniter = tniter + 1
      
C     Compute trust-region radius
      
      if (iter .eq. 1) then
         if (udelta0 .le. 0.0d0) then
            if (trtype .eq. 0) then
               delta = max(delmin, 0.1d0 * max(1.0d0, sqrt(xeucn2)))
            else ! if (trtype .eq. 1) then
               delta = max(delmin, 0.1d0 * max(1.0d0, xsupn))
            end if
         else
            delta = max(delmin, udelta0)
         end if
      else
         if (trtype .eq. 0) then
            delta = max(delmin, 10.0d0 * sqrt(sts))
         else ! if (trtype .eq. 1) then
            delta = max(delmin, 10.0d0 * ssupn)
         end if
      end if    

C     Compute the descent direction solving the newtonian system by 
C     conjugate gradients
      
C     Set conjugate gradient stopping criteria. Default values are 
C     taken if you set ucgeps < 0 or ucgmia < 0 or ucgmib < 0. 
C     Otherwise, the parameters cgeps and cgmaxit will be the ones 
C     set by the user.
      
      if (ucgmia .lt. 0.0d0 .or. ucgmib .lt. 0.0d0) then
c         if ( cgscre .eq. 1 ) then
c            kappa = log10( gpeucn2 / gpeucn20 )/
c     +           log10( epsgpen2 / gpeucn20 )
c         else                   ! if ( cgscre .eq. 2 ) then
c            kappa= log10( gpsupn / gpsupn0 ) / 
c     +           log10( epsgpsn / gpsupn0 )
c         end if
c         kappa = max( 0.0d0, min( 1.0d0, kappa ) )
c         cgmaxit = int( ( 1.0d0 - kappa ) * max( 1.0d0, 
c     +        min( dfloat( nind ), 10.0d0 * 
c     +        log10( dfloat( nind ) ) ) ) + kappa * dfloat( nind ) )
         cgmaxit = max(1, min(2 * nind, 10000))
      else
         cgmaxit = max(1, int(ucgmia * nind + ucgmib))
      end if

      if (gotgp) then
         if (cgscre .eq. 1) then
            cgeps = sqrt(10.0d0 ** (acgeps * log10(gpeucn2) + bcgeps))
         else ! if (cgscre .eq. 2) then
            cgeps = 10.0d0 ** (acgeps * log10(gpsupn) + bcgeps)
         end if
         cgeps = max(cgepsf, min(cgepsi, cgeps))
      else
         cgeps = cgepsf
      end if

C     Call conjugate gradients

      call cgm(nind, ind, nind2, ind2, n, x, ml, mleq, lda, A, b, nact, 
     +     nliact, iact, ldabar, Abar, tau, g, gz, delta, l, u, cgeps, 
     +     epsnqmp, maxitnqmp, cgmaxit, gtype, hptype, trtype, precond, 
     +     samefa, aptype, s, y, seucn, yeucn, sts, sty, lspgmi, lspgma,
     +     iprint, ncomp, dz, wd1, d, wd2, wd3, wd4, wd5, cgiter, rbdlu, 
     +     rbdli, rbdind, wi1, inform, wd6, wd7, wd8, wd9, wd10, wd11, 
     +     wd12, wd13, theta, macheps, bignum)

      hcnt  = hcnt + 1
      cgcnt = cgcnt + cgiter
      
      if (inform .lt. 0) then
         
         if (iprint .ge. 2) then
            write(*, 1000) inform
            write(10,1000) inform
         end if
         
         return
         
      end if
      
C     Set iteration type
      
      if (aptype .eq. 'TRUEHE') then
         ittype = 2
      else if (aptype .eq. 'HLPROD') then
         ittype = 3
      else if (aptype .eq. 'QNCGNA') then
         ittype = 4
      else if (aptype .eq. 'INCQUO') then
         ittype = 5
      else if (aptype .eq. 'PUREIQ') then
         ittype = 6
      end if
      
C     Compute maximum step. If maximum step is taken, rbdlu variables
C     will reach lower or upper bound and rbdli - rbdlu linear
C     constraints will be active. Vector rbdind store in positions 1
C     to rbdlu the indices of variables that will be reach the lower
C     bound and n + index of variables that will reach upper bound  
C     if maximum step is taken; in position rbdlu + 1 to rbdli the
C     indices of linear constraints that will be active if maximum
C     step is taken

      if (inform .eq. 2) then
         amax = 1.0d0
      else
         amax = bignum
         rbdlu = 0
         
         do i = 1, nind2
            ii = ind2(i)
            
            if (d(ii) .gt. 0.0d0) then
               amaxx = (u(ii) - x(ii)) / d(ii)
               if (amaxx .lt. amax - macheps * max(amax, 1.0d0)) then
                  amax  = amaxx
                  rbdlu = 1
                  rbdind(rbdlu) = n + ii
               else
                  if (amaxx .le. amax + macheps * max(amax, 1.0d0)) then
                     rbdlu = rbdlu + 1
                     rbdind(rbdlu) = n + ii
                  end if
               end if
               
            else if (d(ii) .lt. 0.0d0) then
               amaxx = (l(ii) - x(ii)) / d(ii)
               
               if (amaxx .lt. amax - macheps * max(amax, 1.0d0)) then
                  amax  = amaxx
                  rbdlu = 1
                  rbdind(rbdlu) = ii
               else
                  if (amaxx .le. amax + macheps * max(amax, 1.0d0)) then
                     rbdlu = rbdlu + 1
                     rbdind(rbdlu) = ii
                  end if
               end if
               
            end if
         end do         
         
C        Look to the linear inequality constraints
         
         rbdli = rbdlu

         call expand(nind, ind, n, x)
                     
         do i = nact+1, ml
            ii = iact(i)

            ad = 0.0d0
            do j = 1, nind2
               jj  = ind2(j)
               jjj = ind(jj)
               ad = ad + A(ii,jjj) * d(jj)
            end do
            
            if (ad .lt. 0.0d0) then
               ax = 0.0d0
               do j = 1, n
                  ax = ax + A(ii,j) * x(j) 
               end do
               
               amaxx = (b(ii) - ax) / ad
               if (amaxx .lt. amax - macheps * max(amax, 1.0d0)) then
                  amax  = amaxx
                  rbdlu = 0
                  rbdli = 1
                  rbdind(rbdli) = i
               else
                  if (amaxx .le. amax + macheps * max(amax, 1.0d0)) then
                     rbdli = rbdli + 1
                     rbdind(rbdli) = i
                  end if
               end if
            end if
         end do
         
         call shrink(nind, ind, n, x)
      end if

C     Perform the line search
      
      tnintprev = tnintcnt
      fcntprev  = fcnt

      call tnls(nind, ind, nind2, ind2, n, x, ml, mleq, lda, A, b, l, u, 
     +     f, g, d, amax, nact, iact, rbdlu, rbdli, rbdind, etaint, 
     +     mininterp, fmin, maxfc, gtype, iprint, fcnt, gcnt, tnintcnt, 
     +     inform, wd1, wd14, gamma, sigma1, sigma2, lossfeas, epscsn, 
     +     macheps)
      
      if (inform .lt. 0) then
         
         if (iprint .ge. 2) then
            write(*, 1000) inform
            write(10,1000) inform
         end if
         
         return
         
      end if
      
      if (tnintcnt .gt. tnintprev) then
         tnintfe = tnintfe + (fcnt - fcntprev)
      else
         tnstpcnt = tnstpcnt + 1
      end if
      
      tnfcnt = tnfcnt + (fcnt - fcntprev)

 990  format(/,6x,'inner GENCAN iteration')
 1000 format(/6X,'Flag of inner GENCAN = ',I3,' Fatal Error')
      
      end   

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

      subroutine cgm(nind,ind,nind2,ind2,n,x,ml,mleq,lda,A,b,nact,
     +nliact,iact,ldabar,Abar,tau,g,gz,delta,l,u,eps,epsnqmp,maxitnqmp,
     +maxit,gtype,hptype,trtype,precond,samefa,aptype,s,y,seucn,yeucn,
     +sts,sty,lspgmi,lspgma,iprint,ncomp,d,dprev,zd,zdprev,zp,wd1,wd2,
     +iter,rbdlu,rbdli,rbdind,rbdposaind,inform,p,hp,r,z,pdiag,psmdy,
     +hds,wdn1,theta,macheps,bignum)

      implicit none

C     SCALAR ARGUMENTS
      logical samefa
      character * 6 aptype,precond
      integer gtype,hptype,inform,iprint,iter,ml,mleq,lda,maxit,
     +        maxitnqmp,n,ncomp,nind,nind2,trtype,rbdlu,rbdli,nact,
     +        nliact,ldabar
      double precision bignum,delta,eps,epsnqmp,lspgma,lspgmi,macheps,
     +        seucn,sts,sty,theta,yeucn

C     ARRAY ARGUMENTS
      integer ind(nind),ind2(nind),iact(ml),rbdind(n+ml),
     +     rbdposaind(n+ml)
      double precision d(n),g(n),gz(nind-nliact),hds(n),hp(n),l(n),
     +        p(n),pdiag(n),psmdy(n),r(n),s(n),u(n),wdn1(n),x(n),y(n),
     +        z(n),A(lda,n),b(ml),wd1(n),wd2(n),zp(n),dprev(n),
     +        zdprev(n),zd(n),tau(nliact),Abar(ldabar,nliact)

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 reduced Hessian matrix of the 
C     objective function and g is its reduced 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 feasible 
C         set, 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     On Entry
C
C     nind     integer
C              number of free variables
C
C     ind      integer ind(n)
C              array which contains, in the first nind positions, the
C              identifiers of the free variables
C
C     nind2    integer
C              number of truely free variables
C
C     ind2     integer ind2(n)
C              array which contains, in the first nind2 positions, the
C              identifiers of the truely free variables
C
C     n        integer
C              dimension of the full space
C
C     x        double precision x(n)
C              point at which function L is being approximated by the
C              quadratic model
C
C              The first nind positions of x contains the free variables 
C              x_ind(1), x_ind(2), ..., x_ind(nind).
C
C     ml       integer
C              total number of linear constraints (excluding bounds)
C
C     mleq     integer
C              number of linear equality constraints (excluding bounds)     
C      
C     lda      integer
C              leading dimension of matrix A
C      
C     A        double precision A(lda,n)
C              coeficients of linear constraints
C
C     b        double precision b(ml)
C              constant part of linear constraints
C
C     nact     integer
C              number of active linear constraints
C
C     nliact   integer
C              number of linearly independent active linear
C              constraints (nind-nliact is the dimension in 
C              which this subroutine will work)
C
C     iact     integer iact(ml)
C              indices of the active linear constraints. The last 
C              m - nact positions of iact store the identifier of the 
C              non-active linear constraints.
C
C     ldabar   integer
C              leading dimension of matrix Abar
C
C     Abar     double precision Abar(ldabar,nliact)
C              hold the LQ factorization of the matrix whose columns
C              correspond to the active linear constraints, after 
C              eliminating the elements correnponding to fixed variables
C
C     tau      double precision tau(nliact)
C              used to retrieve the columns of Q from Abar
C
C     g        double precision g(n)
C              linear coefficient of the quadratic function before
C              the multiplication by Z^T
C
C     gz       double precision gz(nind-nliact)
C              This is \nabla L(x) and it also contains in the first 
C              nind positions the components g_ind(1), g_ind(2), ..., 
C              g_ind(nind) times Z^T.
C    
C              IMPORTANT: the linear algebra of this subroutine lies in 
C              a space of dimension nind-nliact. The value of the full 
C              dimension n, the non-free variables (which are at the end 
C              of array x) and its gradient components (which are at the 
C              and of array g) are, at this moment, being used to 
C              approximate the Hessian times vector products by 
C              incremental quotients.
C
C     delta    double precision
C              "trust region radius" ( ||d|| <= delta ) 
C    
C     l        double precision l(n)
C              lower bounds on x + d. Its components are ordered in the 
C              same way as x and g.
C
C     u        double precision u(n)
C              upper bounds on x + d. Its components are ordered in the 
C              same way as x, g and l.
C
C     eps      double precision
C              tolerance for the stopping criterion ||H d + g||_2 < eps 
C              * ||g||_2
C
C     epsnqmp  double precision
C              See below
C
C     maxitnqmp integer
C              This and the previous parameter are used for a stopping 
C              criterion of the conjugate gradient subalgorithm. If the 
C              progress in the quadratic model is less than or equal to 
C              a fraction of the best progress ( epsnqmp * bestprog ) 
C              during maxitnqmp consecutive iterations then CG stops by 
C              not enough progress of the quadratic model.
C
C              RECOMMENDED: epsnqmp = 1.0d-4, maxitnqmp = 5
C
C     maxit    integer
C              maximum number of iterations.
C
C              RECOMMENDED: maxit = nind
C
C     gtype    integer
C              type of gradient calculation
C              gtype = 0 means user suplied evalng subroutine,
C              gtype = 1 means central difference approximation.
C
C              RECOMMENDED: gtype = 0
C
C              (provided you have the evalg subroutine)
C
C     hptype   integer
C              Type of Hessian-vector product calculation. See the 
C              detailed explanation in the genlin parameters
C              description.
C
C              RECOMMENDED: hptype = 0
C
C     trtype   integer
C              type of "trust region"
C              trtype = 0 means Euclidian-norm trust-region
C              trtype = 1 means sup-norm trust-region
C
C              RECOMMENDED: trtype = 0
C
C     precond  character * 6
C              indicates the type of preconditioning that will be used
C              for Conjugates Gradients.
C
C              'NONE'   means no preconditioner at all,
C
C              'QNCGNA' means Quasi-Newton Correction of the Gauss-
C                       Newton approximation of the Hessian. The exact
C                       form is this preconditioner is described in:
C 
C                       E. G. Birgin and J. M. Martínez, "Structured 
C                       minimal-memory inexact quasi-Newton method and 
C                       secant preconditioners for Augmented Lagrangian 
C                       Optimization", Computational Optimization and 
C                       Applications, 39, pp, 1-16, 2008.
C
C     samefa   logical
C              true iff current point is in the same face as the 
C              previous one
C
C     s        double precision s(n)
C              diference between x and initial point from previous 
C              iteration
C
C     y        double precision y(n)
C              diference between g and the grandient of the initial 
C              point from previous iteration
C
C     seucn    double precision
C              s Euclidian norm
C
C     yeucn    double precision
C              s Euclidian norm
C
C     sts      double precision
C              scalar product between s and s
C
C     sty      double precision
C              scalar product between s and y
C
C     lspgmi   double precision
C              See below
C
C     lspgma   double precision
C              The spectral steplength, called lamspg, is projected onto 
C              the box [lspgmi,lspgma] 
C
C              RECOMMENDED: lspgmi = 1.0d-10 and lspgma = 1.0d+10
C 
C              CONSTRAINTS: lspgma >= lspgmi > 0.0
C
C     iprint   integer
C              Commands printing. Nothing is printed if iprint is 
C              smaller than 2. If iprint is greater than or equal to 
C              2, WFGENCAN iterations information is printed. If iprint 
C              is greater than or equal to 3, line searches and 
C              Conjugate Gradients information is printed.
C
C              RECOMMENDED: iprint = 2
C
C              CONSTRAINTS: allowed values are just 2 or 3.
C
C     ncomp    integer
C              This constant is just for printing. In a detailed 
C              printing option, ncomp component of some vectors will be 
C              printed
C
C              RECOMMENDED: ncomp = 5
C
C              CONSTRAINTS: ncomp >= 0
C
C     d,dprev,zp,wd1,wd2,p,hp,r,z,pdiag,psmdy,hds,wdn1
C              double precision d,dprev,zp,wd1,wd2,p,hp,r,z,pdiag,psmdy,
C                               hds,wdn1(n)
C              n-dimensional working vectors of doubles
C
C     zdprev   double precision zdprev(nind-nliact)
C              (nind-nliact)-dimensional working vectors of doubles
C
C     rbsposaind integer rbdposaind(n+ml)
C              working vector of integers
C
C     theta    double precision
C              constant for the angle condition, i.e., at iteration k we 
C              need a direction pk such that 
C
C              <gk,pk> <= - theta ||gk||_2 ||pk||_2, 
C
C              where gk is \nabla L(xk)
C
C              RECOMMENDED: theta = 10^{-6}
C
C     macheps  double precision
C              macheps is the smallest positive number such that
C              1 + macheps is not equal to 1
C
C     bignum   double precision
C              a big number, like 10^{99}
C
C     On Return
C
C     aptype   character * 6
C              type of matrix-vector product and preconditioner used
C
C     zd       double precision d(nind-nliact)
C              final estimation of the solution
C
C     iter     integer
C              number of Conjugate Gradient iterations performed
C
C     rbdlu    integer
C              number of variables that reached a lower or upper 
C              bound
C
C     rbdli    integer
C              total number of new active constraints. rbdli-rbdlu
C              is the number of linear constraints that are now 
C              satisfied by equality
C
C     rbdind   integer rbdind(n+ml)
C              indices of bound and linear constraints that are 
C              satisfied by equality at the new point x. That is, 
C              indices of the constraints to be added to the active set)
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
C            < 0 = error in evalhessp subroutine.

C     LOCAL SCALARS
      character * 4 cgtype
      character * 6 rbdtypea
      character * 6 prectmp
      logical goth,gotp,negcur,restarted,samep
      integer i,ii,j,jj,itertmp,itnqmp,nred,rbdposalu, rbdposali
      double precision aa,alpha,amax,amax1,amax2,amax2x,bb,bestprog,
     +        beta,cc,currprog,dd,dnorm2,gznorm2,gtd,gtp,hlspg,hstds,
     +        norm2s,pnorm2,plspg,psmdyty,ptd,pthp,ptr,q,qprev,rnorm2,
     +        ztrprev,ztr,znorm2,ax,azd,azp

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

      restarted = .false.

 001  continue

      goth = .false.
      gotp = .false.

      nred    = nind - nliact
      gznorm2 = norm2s(nred,gz)

      iter     =      0
      itnqmp   =      0
      qprev    = bignum
      bestprog =  0.0d0

      do i = 1,nred
          d(i) = 0.0d0
          r(i) =  gz(i)
      end do

      do i = 1,nind
         zd(i)     = 0.0d0
         zdprev(i) = 0.0d0
      end do

      q        =   0.0d0
      gtd      =   0.0d0
      dnorm2   =   0.0d0
      rnorm2   = gznorm2

      ztr      =  0.0d0

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

      if ( iprint .ge. 3 ) then

          if ( precond .eq. 'NONE' ) then
              cgtype = '    '
          else
              cgtype = 'PREC'
          end if

          write(*, 980) cgtype,maxit,eps
          if ( trtype .eq. 0 ) then
              write(*, 981) delta
          else if ( trtype .eq. 1 ) then
              write(*, 982) delta
          else
              write(*, 983)
          end if
          write(*, 984) iter,sqrt(rnorm2),sqrt(dnorm2),q

          write(10,980) cgtype,maxit,eps
          if ( trtype .eq. 0 ) then
              write(10,981) delta
          else if ( trtype .eq. 1 ) then
              write(10,982) delta
          else
              write(10,983)
          end if
          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 * gznorm2 .and. iter .ge. 4 ) .or. 
     +     ( rnorm2 .le. 1.0d-16 ) ) ) then 

          inform = 0

          if ( iprint .ge. 3 ) then
              write(*, 990) inform
              write(10,990) inform
          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

          inform = 8

          if ( iprint .ge. 3 ) then
              write(*, 998) inform
              write(10,998) inform
          end if
  
          go to 500

      end if

C     ==================================================================
C     Preconditioner
C     ==================================================================

      if ( precond .eq. 'NONE' ) then

          do i = 1,nred
              z(i) = r(i)
          end do

          ztrprev = ztr
          ztr     = rnorm2
          znorm2  = rnorm2

      else if ( precond .eq. 'QNCGNA' ) then

          call calcpz(nind,ind,n,r,s,y,seucn,yeucn,sts,sty,lspgmi,
     +    lspgma,samefa,gotp,pdiag,plspg,psmdy,psmdyty,z)

          ztrprev = ztr

          ztr = 0.0d0
          do i = 1,nred
              ztr = ztr + z(i) * r(i)
          end do

          znorm2 = norm2s(nred,z)
      end if

C     ==================================================================
C     Compute direction
C     ==================================================================

      if ( iter .eq. 0 ) then

          do i = 1,nred
              p(i) = - z(i)
          end do

          ptr    = - ztr
          pnorm2 =   znorm2

      else

          beta = ztr / ztrprev

          do i = 1,nred
              p(i) = - z(i) + beta * p(i)
          end do

          if ( precond .eq. 'NONE' ) then

              pnorm2 = rnorm2 - 2.0d0 * beta * ( ptr + alpha * pthp ) 
     +               + beta ** 2 * pnorm2
              ptr = - rnorm2 + beta * ( ptr + alpha * pthp )

          else if ( precond .eq. 'QNCGNA' ) then

              ptr = 0.0d0
              pnorm2 = 0.0d0
              do i = 1,nred
                  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,nred
              p(i) = - p(i)
          end do

          ptr = - ptr

      end if

C     ==================================================================
C     Compute p^T Z^T H Z p
C     ==================================================================

C     zp = Z p
      
      call multZ(nind, nliact, ldabar, Abar, tau, p, zp, macheps)
            
C     wd1 = H zp = H Z p

      call calchessp(nind,ind,x,zp,g,n,x,s,y,seucn,yeucn,sts,sty,lspgmi,
     +lspgma,samefa,gtype,hptype,aptype,wd1,wdn1,macheps,inform,goth,
     +hlspg,hds,hstds)

      if ( inform .lt. 0 ) then

          if ( iprint .ge. 3 ) then
              write(*, 1000) inform
              write(10,1000) inform
          end if

          return
      end if

C     hp = Z^T wd1 = Z^T H zp = Z^T H Z p

      call multZT(nind, nliact, ldabar, Abar, tau, wd1, wd2, hp,
     +     macheps)      

C     Compute p^T hp = p^T Z^T wd1 = p^T Z^T H Z p 

      pthp = 0.0d0
      do i = 1,nred
          pthp = pthp + p(i) * hp(i)
      end do 

C     ==================================================================
C     Compute maximum steps
C     ==================================================================

C     amax1 is the value of alpha such that ||d + alpha * p||_2 or 
C     ||d + alpha * p||_\infty = delta 

      ptd = 0.0d0
      do i = 1,nred
          ptd = ptd + p(i) * d(i)
      end do

C     Euclidian-norm trust radius

      if ( trtype .eq. 0 ) then

          aa = pnorm2
          bb = 2.0d0 * ptd
          cc = dnorm2 - delta ** 2
          dd = sqrt( bb ** 2 - 4.0d0 * aa * cc )

          amax1 = ( - bb + dd ) / ( 2.0d0 * aa )

      else if ( trtype .eq. 1 ) then

          amax1 = bignum

          do i = 1,nred
              if ( p(i) .gt. 0.0d0 ) then
                  amax1 = min( amax1,  (   delta - d(i) ) / p(i) )
              else if ( p(i) .lt. 0.0d0 ) then
                  amax1 = min( amax1,  ( - delta - d(i) ) / p(i) )
              end if
          end do

      end if

C     amax2 is the maximum values of alpha such that 
C     l <= x + d + alpha * p <= u

      amax2     = bignum     
      rbdposalu = 0

      do i = 1, nind2
         ii = ind2(i)
         
         if (zp(ii) .gt. 0.0d0) then
            amax2x = (u(ii) - x(ii) - zd(ii)) / zp(ii)

            if (amax2x .lt. amax2 - macheps * max(amax2, 1.0d0)) then
               amax2     = amax2x
               rbdposalu = 1
               rbdposaind(rbdposalu) = ii + n
            else if (amax2x .le. amax2+macheps * max(amax2, 1.0d0)) then
               rbdposalu = rbdposalu + 1
               rbdposaind(rbdposalu) = ii + n
            end if
            
         else if (zp(ii) .lt. 0.0d0) then
            amax2x = (l(ii) - x(ii) - zd(ii)) / zp(ii)

            if (amax2x .lt. amax2 - macheps * max(amax2, 1.0d0)) then
               amax2     = amax2x
               rbdposalu = 1
               rbdposaind(rbdposalu) = ii
            else if (amax2x .le. amax2+macheps * max(amax2, 1.0d0)) then
               rbdposalu = rbdposalu + 1
               rbdposaind(rbdposalu) = ii
            end if
         end if
      end do

C     amax2 > 0 is also the maximum value of alpha such that
C     A(x + Z s + alpha * Z d) >= b

C     Look to the linear inequality constraints
      
      rbdposali = rbdposalu

      call expand(nind, ind, n, x)

      do i = nact+1, ml
         ii = iact(i)

         azp = 0.0d0
         do j = 1, nind
            jj = ind(j)
            azp = azp + A(ii,jj) * zp(j) 
         end do
         
         azd = 0.0d0
         do j = 1, nind
            jj = ind(j)
            azd = azd + A(ii,jj) * zd(j) 
         end do
         
         ax = 0.0d0
         do j = 1, n
            ax = ax + A(ii,j) * x(j) 
         end do
         
         if (azp .lt. 0.0d0) then
            
            amax2x = (b(ii) - azd - ax) / azp

            if (amax2x .lt. amax2 - macheps * max(amax2, 1.0d0)) then
               amax2     = amax2x
               rbdposalu = 0
               rbdposali = 1
               rbdposaind(rbdposali) = i
            else if (amax2x .le. amax2+macheps * max(amax2, 1.0d0)) then
               rbdposali = rbdposali + 1
               rbdposaind(rbdposali) = i
            end if
         end if
      end do

      call shrink(nind, ind, n, x)

C     Compute amax as the minimum among amax1 and amax2

      amax = min(amax1, amax2)

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 

          inform = 7

          if ( iprint .ge. 3 ) then
              write(*, 997) inform
              write(10,997) inform
          end if
  
          go to 500

      end if

C     ==================================================================
C     Test the angle condition
C     ==================================================================

      gtp = 0.0d0
      do i = 1,nred
          gtp = gtp + gz(i) * p(i)
      end do

      gtd = gtd + alpha * gtp
      dnorm2 = dnorm2 + alpha ** 2 * pnorm2 + 2.0d0 * alpha * ptd

      if ( gtd .gt. 0.0d0 .or. 
     +gtd ** 2 .lt. theta ** 2 * gznorm2 * dnorm2 ) then

          if ( precond .ne. 'NONE' .and. iter .eq. 0 ) then

              if ( iprint .ge. 3 ) then
                  write(*, 986)
                  write(10,986)
              end if

              restarted = .true.
              itertmp   = iter
              prectmp   = precond
              precond   = 'NONE'
              go to 001

          end if

          inform = 3

          if ( iprint .ge. 3 ) then
              write(*, 993) inform
              write(10,993) inform
          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,nred
          dprev(i) = d(i)
          d(i)     = d(i) + alpha * p(i)
      end do

      do i = 1, nind
         zdprev(i) = zd(i)
         zd(i)     = zd(i) + alpha * zp(i)
      end do

      dnorm2 = dnorm2 + alpha**2 * pnorm2 + 2.0d0 * alpha * ptd

C     ==================================================================
C     Compute the residual r = H d + g
C     ==================================================================

      do i = 1,nred
          r(i) = r(i) + alpha * hp(i)
      end do

      rnorm2 = norm2s(nred,r)

C     ==================================================================
C     Increment number of iterations
C     ==================================================================

      iter = iter + 1

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

      if ( iprint .ge. 3 ) 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 feasible set

      if ( alpha .eq. amax2 ) then

         rbdlu = rbdposalu
         rbdli = rbdposali

         do i = 1, rbdli
            rbdind(i) = rbdposaind(i)
         end do
         
         if (rbdlu .eq. 0) then
            rbdtypea = 'linear'
         else if (rbdind(1) .gt. n) then
            rbdtypea = 'upper'
         else               
            rbdtypea = 'lower'
         end if
         
         inform = 2

         if (iprint .ge. 3) then

            if ( negcur ) then
               write(*, 999)
               write(10,999)
            end if

            if ( rbdli .eq. 0 ) then
               write(*, 987) inform
               write(10,987) inform
            else 
               if (rbdlu .eq. 0) then
                  write(*, 995) inform, rbdind(1)
                  write(10,995) inform, rbdind(1)
               else
                  if (rbdind(1) .gt. n) then
                     write(*, 992) inform, ind(rbdind(1)-n), rbdtypea
                     write(10,992) inform, ind(rbdind(1)-n), rbdtypea
                  else
                     write(*, 992) inform, ind(rbdind(1)), rbdtypea
                     write(10,992) inform, ind(rbdind(1)), rbdtypea
                  end if
               end if
            end if
         end if
         
         go to 500
         
      end if

C     Boundary of the "trust region"

      if ( alpha .eq. amax1 ) then

          inform = 1
         
          if ( iprint .ge. 3 ) then
              if ( negcur ) then
                  write(*, 999)
                  write(10,999)
              end if

              write(*, 991) inform
              write(10,991) inform
          end if
  
          go to 500

      end if

C     Two consecutive iterates are too much close

      samep = .true.
      do i = 1,nred
         if ( abs( alpha * p(i) ) .gt. 
     +        macheps * max( abs( d(i) ) , 1.0d0 ) ) then 
             samep = .false.
         end if
      end do

      if ( samep ) then

          inform = 6

          if ( iprint .ge. 3 ) then
              write(*, 996) inform
              write(10,996) inform
          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. maxitnqmp ) then
              inform = 4

              if ( iprint .ge. 3 ) then
                  write(*, 994) inform,itnqmp,epsnqmp,bestprog
                  write(10,994) inform,itnqmp,epsnqmp,bestprog
              end if

              go to 500
          end if

      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 ( iprint .ge. 3 ) then
          write(*, 985) min0(nred,ncomp),(d(i),i=1,min0(nred,ncomp))
          write(10,985) min0(nred,ncomp),(d(i),i=1,min0(nred,ncomp))
      end if

      if ( restarted ) then
          iter = iter + itertmp
          precond = prectmp
      end if

C     Non-executable statements

 980  format(/,6x,'Conjugate gradients ',A4,' (maxit= ',I7,' acc= ',
     *1PD11.4,')')
 981  format(6x,'Using Euclidian trust region (delta= ',1PD11.4,
     *')')
 982  format(6x,'Using sup-norm trust region (delta= ',1PD11.4,')')
 983  format(6x,'Unknown trust-region type')
 984  format(6x,'CG iter= ',I5,' rnorm: ',1PD11.4,' dnorm= ',1PD11.4,
     *' q= ',1PD11.4)
 985  format(/,6x,'Truncated Newton direction (first ',I6, 
     *' components): ',/,1(6x,6(1PD11.4,1x)))
 986  format(6x,'The first CG-PREC iterate did not satisfy the angle ',
     *' condition. CG will be restarted without preconditioner)')
 987  format(6x,'Flag of CG = ',I3,
     *' (Taking a too large step, no variable will reach its bound)')      
 990  format(6x,'Flag of CG = ',I3,' (Convergence with small residual)')
 991  format(6x,'Flag of CG = ',I3,
     *' (Convergence to the trust region boundary)')
 992  format(6x,'Flag of CG = ',I3,
     *' (Convergence to the boundary of the feasible set,',/,6x,
     *'taking step >= 1, variable ',I6,' will reach its ',A6,
     *' bound)')
 995  format(6x,'Flag of CG = ',I3,
     +     ' (Convergence to the boundary of the feasible set,',/,6x,
     +     'taking step >= 1, linear constraint ',I6,
     +     ' will reach its bound)') 
 993  format(6x,'Flag of CG = ',I3,
     *' (The next CG iterate will not satisfy the angle condition)')
 994  format(6x,'Flag of CG = ',I3,
     *' (Not enough progress in the quadratic model. This means',/,6x,
     *'that the progress of the last ',I7,' iterations was smaller ', 
     *'than ',/,6x,1PD11.4,' times the best progress (',1PD11.4,')')
 996  format(6x,'Flag of CG = ',I3,
     *' (Very near consecutive iterates)')
 997  format(6x,'Flag of CG= ',I3,
     *' (p such that p^T H p = 0 was found)')
 998  format(6x,'Flag of CG = ',I3,' (Too many GC iterations)')
 999  format(6x,'p such that p^T H p = 0 was found. ',
     *     'Maximum step was taken.')
 1000 format(6x,'Flag of CG = ',I3,' Fatal Error')

      end

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

      subroutine tnls(nind,ind,nind2,ind2,n,x,ml,mleq,lda,A,b,l,u,f,g,d,
     +amax,nact,iact,rbdlu,rbdli,rbdind,etaint,mininterp,fmin,maxfc,
     +gtype,iprint,fcnt,gcnt,intcnt,inform,xplus,wd1,gamma,sigma1,
     +sigma2,lossfeas,epscsn,macheps)

      implicit none

C     SCALAR ARGUMENTS
      logical lossfeas
      integer fcnt,gcnt,gtype,inform,intcnt,iprint,maxfc,mininterp,n,
     +        nind,nind2,ml,mleq,nact,lda,rbdlu,rbdli
      double precision amax,etaint,f,fmin,gamma,epscsn,macheps,sigma1,
     +        sigma2

C     ARRAY ARGUMENTS
      integer ind(nind),ind2(nind),iact(ml),rbdind(n+ml)
      double precision d(n),g(n),l(n),u(n),x(n),xplus(n),wd1(ml),
     +        A(lda,n),b(ml)

C     This subroutine implements the line search used in the Truncated
C     Newton direction.
C
C     On Entry
C
C     nind     integer
C              number of free variables (this is thee dimension in 
C              which this subroutine will work)
C
C     ind      integer ind(n)
C              array which contains, in the first nind positions, the
C              identifiers of the free variables
C
C     nind2    integer
C              number of truely free variables
C
C     ind2     integer ind2(n)
C              array which contains, in the first nind2 positions, the
C              identifiers of the truely free variables
C
C     n        integer
C              dimension of the full space
C
C     x        double precision x(n)
C              current point
C
C              The first nind positions of x contains the free variables 
C              x_ind(1), x_ind(2), ..., x_ind(nind).
C
C     ml       integer
C              total number of linear constraints (excluding bounds)
C
C     mleq     integer
C              number of linear equality constraints (excluding bounds)     
C      
C     lda      integer
C              leading dimension of matrix A
C      
C     A        double precision A(lda,n)
C              coeficients of linear constraints
C
C     b        double precision b(ml)
C              constant part of linear constraints
C
C     l        double precision l(nind)
C              lower bounds on x. It components are ordered in the
C              same way as x and g.
C
C     u        double precision u(nind)
C              upper bounds on x. It components are ordered in the
C              same way as x, g and l.
C
C     f        double precision
C              functional value at x
C
C     g        double precision g(n)
C              gradient vector at x
C
C              It also contains in the first nind positions the 
C              components g_ind(1), g_ind(2), ..., g_ind(nind).
C    
C              IMPORTANT: the linear algebra of this subroutine lies in 
C              a space of dimension nind. The value of the full 
C              dimension n, the non-free variables (which are at the end 
C              of array x) and its gradient components (which are at the 
C              end of array g) are also used and updated any time the 
C              gradient is being computed.
C
C     d        double precision d(nind)
C              descent direction 
C    
C     amax     double precision
C
C     nact     integer
C              number of active linear constraints
C
C     iact     integer iact(ml)
C              indices of the active linear constraints. The last 
C              m - nact positions of iact store the identifier of the 
C              non-active linear constraints.
C
C     etaint   double precision
C              constant for the interpolation. See the description of
C              sigma1 and sigma2 above. Sometimes we take as a new 
C              trial step the previous one divided by etaint
C
C              RECOMMENDED: etaint = 2.0
C
C     mininterp integer
C              constant for testing if, after having made at least 
C              mininterp interpolations, the steplength is so small. 
C              In that case failure of the line search is declared (may 
C              be the direction is not a descent direction due to an 
C              error in the gradient calculations) 
C
C              RECOMMENDED: mininterp = 4
C
C     fmin     double precision
C              functional value for the stopping criteria f <= fmin
C
C     maxfc    integer
C              maximum number of functional evaluations
C
C     gtype    integer
C              type of gradient calculation
C              gtype = 0 means user suplied evalg subroutine,
C              gtype = 1 means central difference approximation.
C
C              RECOMMENDED: gtype = 0
C
C              (provided you have the evalg subroutine)
C
C     iprint   integer
C              Commands printing. Nothing is printed if iprint is 
C              smaller than 2. If iprint is greater than or equal to 
C              2, WFGENCAN iterations information is printed. If iprint 
C              is greater than or equal to 3, line searches and 
C              Conjugate Gradients information is printed.
C
C              RECOMMENDED: iprint = 2
C
C              CONSTRAINTS: allowed values are just 2 or 3.
C
C     xplus,wd1 double precision xplus,wd1(n)
C              n-dimensional working vectors of doubles
C
C     gamma    double precision
C              constant for the Armijo criterion
C              f(x + alpha d) <= f(x) + gamma * alpha * <\nabla f(x),d>
C
C              RECOMMENDED: gamma = 10^{-4}
C
C     sigma1   double precision
C     sigma2   double precision
C              constant for the safeguarded interpolation
C              if alpha_new \notin [sigma1, sigma*alpha] then we take
C              alpha_new = alpha / etaint
C
C              RECOMMENDED: sigma1 = 0.1 and sigma2 = 0.9
C
C     lossfeas logical
C              if a loss of feasibility up to sqrt(epsfeas) is allowed
C              during the computations, lossfeas must be set to TRUE
C              (recommended). In this case, if the final iterate does
C              not satisfy the constraints with the desired precision,
C              we sugest that the user re-run the method using the final
C              point obtained as the initial point, using
C              lossfeas = FALSE
C
C     epscsn   double precision
C              feasibility tolerance for the sup-norm of the linear
C              constraints
C     
C     macheps  double precision
C              macheps is the smallest positive number such that
C              1 + macheps is not equal to 1
C
C     On Return
C
C     x        double precision x(n)
C              new current point
C
C     f        double precision
C              functional value at x
C
C     g        double precision g(n)
C              gradient vector at x
C
C     rbdlu    integer
C              number of variables that reached a lower or upper 
C              bound
C
C     rbdli    integer
C              total number of new active constraints. rbdli-rbdlu
C              is the number of linear constraints that are now 
C              satisfied by equality
C
C     rbdind   integer rbdind(n+ml)
C              indices of bound and linear constraints that are 
C              satisfied by equality at the new point x. That is, 
C              indices of the constraints to be added to the active set)
C
C     fcnt     integer
C              number of functional evaluations used in this line search
C
C     gcnt     integer
C              number of gradient evaluations used in this line search
C
C     intcnt   integer
C              number of interpolations
C
C     inform   integer
C              This output parameter tells what happened in this 
C              subroutine, according to the following conventions:
C
C              0 = convergence with an Armijo-like criterion
C                  (f(xnew) <= f(x) + 1.0d-4 * alpha * <g,d>);
C
C              3 = new point x is in the boundary of the current face;
C
C              4 = the algorithm stopped because the functional value
C                  is very small (f <= fmin);
C
C              6 = so small step in the line search. After having made 
C                  at least mininterp interpolations, the steplength 
C                  becames small. ``small steplength'' means that we are 
C                  at point x with direction d and step alpha such that
C
C                  |alpha * d(i)| <= macheps * max ( |x(i)|, 1 )
C
C                  for all i. 
C 
C                  In that case failure of the line search is declared 
C                  (may be the direction is not a descent direction 
C                  due to an error in the gradient calculations). Use
C                  mininterp > maxfc for inhibit this criterion;
C
C              8 = it was achieved the maximum allowed number of
C                  function evaluations (maxfc);
C
C             10 = new point x+alpha*d is infeasible, so x is returned;
C
C            < 0 = error in evalf or evalg subroutines.

C     LOCAL SCALARS
      logical samep
      integer i,ii,j,index,interp
      double precision alpha,atmp,fplus,gtd

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

C     ==================================================================
C     Compute directional derivative
C     ==================================================================

      gtd = 0.0d0
      do i = 1,nind
          gtd = gtd + g(i) * d(i)
      end do

C     ==================================================================
C     Compute first trial
C     ==================================================================

      alpha = min( 1.0d0, amax )

      do i = 1,nind
          xplus(i) = x(i) + alpha * d(i)
      end do

      if (alpha .eq. amax) then
          do i = 1, rbdlu
              index = rbdind(i)
              if (index .gt. n) then
                  xplus(index-n) = u(index-n)
              else
                  xplus(index) = l(index)
              end if
          end do
      end if

C     Test whether at least mininterp interpolations were made and two 
C     consecutive iterates are much close

      samep = .true.

      do i = 1,nind
         if ( abs( alpha * d(i) ) .gt. 
     +        macheps * max( abs( xplus(i) ), 1.0d0 ) ) then
             samep = .false.
         end if
      end do

      if ( samep ) then
         inform = 6

          if ( iprint .ge. 3 ) then
              write(*, 996) inform
              write(10,996) inform
          end if

         go to 500
      end if

C     Check if new point xtrial is feasible. If the lossfeas = true, 
C     then a loss of feasibility up to sqrt(epscsn) is accepted

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

      do i = 1, ml
         wd1(i) = 0.0d0
      end do

      call expand(nind, ind, n, xplus)
      
      do i = 1, n
         do j = 1, ml
            wd1(j) = wd1(j) + A(j,i) * xplus(i)
         end do
      end do
      
      call shrink(nind, ind, n, xplus)

      if (lossfeas) then
         do i = 1, mleq
            if (abs(wd1(i) - b(i)) .gt. sqrt(epscsn)) then
               
               if (iprint .ge. 3) then
                  write(*, *) '     x+d is infeasible.'
                  write(*, *) '     Inner algoritm will stop.'
                  write(10,*) '     x+d is infeasible.'
                  write(10,*) '     Inner algoritm will stop.'
               end if
               
               inform = 10
               return
            end if
         end do
         
         do i = mleq+1, ml
            if (b(i) - wd1(i) .gt. sqrt(epscsn)) then
               
               if (iprint .ge. 3) then
                  write(*, *) '     x+d is infeasible.'
                  write(*, *) '     Inner algoritm will stop.'
                  write(10,*) '     x+d is infeasible.'
                  write(10,*) '     Inner algoritm will stop.'
               end if
               
               inform = 10
               return
            end if
         end do
      else
         do i = 1, mleq
            if (abs(wd1(i) - b(i)) .gt. epscsn) then
               
               if (iprint .ge. 3) then
                  write(*, *) '     x+d is infeasible.'
                  write(*, *) '     Inner algoritm will stop.'
                  write(10,*) '     x+d is infeasible.'
                  write(10,*) '     Inner algoritm will stop.'
               end if
               
               inform = 10
               return
            end if
         end do
         
         do i = mleq+1, ml
            if (b(i) - wd1(i) .gt. epscsn) then
               
               if (iprint .ge. 3) then
                  write(*, *) '     x+d is infeasible.'
                  write(*, *) '     Inner algoritm will stop.'
                  write(10,*) '     x+d is infeasible.'
                  write(10,*) '     Inner algoritm will stop.'
               end if
               
               inform = 10
               return
            end if
         end do
      end if

      interp = 0

 120  continue

      call calcobj(nind,ind,xplus,n,x,fplus,inform)
      fcnt = fcnt + 1
          
      if ( inform .lt. 0 ) then

C        Print information of this iteration

         if ( iprint .ge. 3 ) then
            write(*, 999) alpha,fplus,fcnt
            write(10,999) alpha,fplus,fcnt
         end if
         
         if ( iprint .ge. 3 ) then
            write(*, *) '     f(x+d) is undefined.'
            write(*, *) '     Will interpolate.'
            write(10,*) '     f(x+d) is undefined.'
            write(10,*) '     Will interpolate.'
         end if
             
C        Compute new step

         interp = interp + 1
         alpha  = alpha / etaint

C        Compute new trial point
         
         do i = 1,nind
            xplus(i) = x(i) + alpha * d(i)
         end do
         
C        Test whether at least mininterp interpolations were made and
C        two consecutive iterates are much close

         samep = .true.
         do i = 1,nind
            if ( abs( alpha * d(i) ) .gt. 
     +           macheps * max( abs( xplus(i) ), 1.0d0 ) ) then
               samep = .false.
            end if
         end do
         
         if ( samep ) then
            inform = 6
            
            if ( iprint .ge. 3 ) then
               write(*, 996) inform
               write(10,996) inform
            end if
            
            go to 500
         end if

         go to 120
      end if

C     Print initial information

      if ( iprint .ge. 3 ) then
          write(*, 980) amax
          write(*, 999) alpha,fplus,fcnt

          write(10,980) amax
          write(10,999) alpha,fplus,fcnt
      end if

C     ==================================================================
C     Test Armijo and beta-condition and decide for accepting the trial 
C     point, interpolate or extrapolate.
C     ==================================================================

c      if ( amax .gt. 1.0d0 ) then
      if ( alpha .lt. amax ) then

C         x + d belongs to the interior of the feasible set
          if ( iprint .ge. 3 ) then
              write(*, *) '     x+d belongs to int of the feasible set'
              write(10,*) '     x+d belongs to int of the feasible set'
          end if

C         Verify Armijo

          if ( fplus .le. f + gamma * alpha * gtd ) then

C             Armijo condition holds  
              if ( iprint .ge. 3 ) then
                  write(*, *) '     Armijo condition holds' 
                  write(10,*) '     Armijo condition holds' 
              end if

C             If interpolation is done to make the new point feasible

              f = fplus
                 
              do i = 1,nind
                  x(i) = xplus(i)
              end do
                 
              call calcgr(nind,ind,x,n,x,g,gtype,macheps,inform)
              gcnt = gcnt + 1
                 
              if ( inform .lt. 0 ) then
                 
                  if ( iprint .ge. 3 ) then
                      write(*, 1000) inform
                      write(10,1000) inform
                  end if
                 
                  return
                 
              end if
                 
              inform = 0
                 
              if ( iprint .ge. 3 ) then
                  write(*, 990) inform
                  write(10,990) inform
              end if
                 
              go to 500

          else 

C             Interpolate
              if ( iprint .ge. 3 ) then
                  write(*, *) '     Armijo does not hold'
                  write(*, *) '     We will interpolate'
                  write(10,*) '     Armijo does not hold'
                  write(10,*) '     We will interpolate'
              end if

              go to 200

          end if

      else

C         x + d does not belong to the feasible set (amax <= 1)
          if ( iprint .ge. 3 ) then
              write(*, *) '     x+d does not belong to feasible set'
              write(10,*) '     x+d does not belong to feasible set'
          end if

          if ( fplus .lt. f ) then

              f = fplus
                 
              do i = 1,nind
                  x(i) = xplus(i)
              end do
                 
              call calcgr(nind,ind,x,n,x,g,gtype,macheps,inform)
              gcnt = gcnt + 1
                 
              if ( inform .lt. 0 ) then
                 
                  if ( iprint .ge. 3 ) then
                      write(*, 1000) inform
                      write(10,1000) inform
                  end if
                 
                  return
                 
              end if

C             New point x is in the boundary, rbdind is updated

              rbdlu = 0
              
              do i = 1, nind2
                 ii = ind2(i)
                 
                 if (x(ii) .le. l(ii) + macheps * 
     +                max(abs(l(ii)), 1.0d0)) then
                    x(ii) = l(ii)
                    rbdlu = rbdlu + 1
                    rbdind(rbdlu) = ii
                 else if (x(ii) .ge. u(ii) - macheps *
     +                   max(abs(u(ii)), 1.0d0)) then
                    x(ii) = u(ii)
                    rbdlu = rbdlu + 1
                    rbdind(rbdlu) = ii + n
                 end if
              end do
              
C             Look to the linear inequality constraints
                 
              rbdli = rbdlu
              
              call expand(nind, ind, n, x)                 
              
              do i = 1, ml-nact
                 wd1(i) = 0.0d0
              end do
              
              do j = 1, n
                 do i = nact+1, ml
                    ii = iact(i)
                    wd1(i-nact) = wd1(i-nact) + A(ii,j) * x(j) 
                 end do
              end do
              
              do i = nact+1, ml
                 ii = iact(i)
                 
                 if (abs(wd1(i-nact)-b(ii)) .le. epscsn) then
                    rbdli = rbdli + 1
                    rbdind(rbdli) = i
                 end if
              end do
              
              call shrink(nind, ind, n, x)    
              
              if (rbdli .gt. 0) then
                 inform = 3
              else
                 inform = 0
              end if
              
              go to 500

          else 

C             Interpolate
              if ( iprint .ge. 3 ) then
                  write(*, *) '     f(x+d) >= f(x)'
                  write(*, *) '     We will interpolate'
                  write(10,*) '     f(x+d) >= f(x)'
                  write(10,*) '     We will interpolate'
              end if

              go to 200

          end if

      end if

C     ==================================================================
C     Interpolation
C     ==================================================================

 200  continue

      intcnt = intcnt + 1

c      interp = 0

 210  continue

C     Test f going to -inf

      if ( fplus .le. fmin ) then

C         Finish the interpolation with the current point

          f = fplus

          do i = 1,nind
              x(i) = xplus(i)
          end do

          call calcgr(nind,ind,x,n,x,g,gtype,macheps,inform)
          gcnt = gcnt + 1

          if ( inform .lt. 0 ) then

              if ( iprint .ge. 3 ) then
                  write(*, 1000) inform
                  write(10,1000) inform
              end if

              return

          end if

          inform = 4

          if ( iprint .ge. 3 ) then
              write(*, 994) inform
              write(10,994) inform
          end if

          go to 500

      end if

C     Test maximum number of functional evaluations

      if ( fcnt .ge. maxfc ) then

C         As this is an abrupt termination then the current point of the 
C         interpolation may be worst than the initial one

C         If the current point is better than the initial one then
C         finish the interpolation with the current point else discard
C         all we did inside this line search and finish with the initial
C         point

          if ( fplus .lt. f ) then

              f = fplus

              do i = 1,nind
                  x(i) = xplus(i)
              end do

              call calcgr(nind,ind,x,n,x,g,gtype,macheps,inform)
              gcnt = gcnt + 1

              if ( inform .lt. 0 ) then

                  if ( iprint .ge. 3 ) then
                      write(*, 1000) inform
                      write(10,1000) inform
                  end if

                  return

              end if

          end if

          inform = 8

          if ( iprint .ge. 3 ) then
              write(*, 998) inform
              write(10,998) inform
          end if

          go to 500

      end if

C     Test Armijo condition

      if ( fplus .le. f + gamma * alpha * gtd ) then

C         Finish the line search
      
          f = fplus

          do i = 1,nind
              x(i) = xplus(i)
          end do

          call calcgr(nind,ind,x,n,x,g,gtype,macheps,inform)
          gcnt = gcnt + 1

          if ( inform .lt. 0 ) then

              if ( iprint .ge. 3 ) then
                  write(*, 1000) inform
                  write(10,1000) inform
              end if

              return

          end if

          if ( alpha .ge. amax ) then
              inform = 3
          else
              inform = 0
          end if

          if ( iprint .ge. 3 ) then
              write(*, 990) inform
              write(10,990) inform
          end if

          go to 500

      end if

C     Compute new step

      interp = interp + 1

      atmp = ( - gtd * alpha **2 ) / 
     +           (2.0d0 * ( fplus - f - alpha * gtd ) )

      if ( ( atmp .lt. sigma1 * alpha ) .or. 
     +     ( atmp .gt. sigma2 * alpha ) ) then
          alpha = alpha / etaint
      else
          alpha = atmp
      end if

C     Compute new trial point

      do i = 1,nind
          xplus(i) = x(i) + alpha * d(i)
      end do

      call calcobj(nind,ind,xplus,n,x,fplus,inform)
      fcnt = fcnt + 1

      if ( inform .lt. 0 ) then

          if ( iprint .ge. 3 ) then
              write(*, 1000) inform
              write(10,1000) inform
          end if

          return

      end if

C     Print information of this iteration

      if ( iprint .ge. 3 ) then
          write(*, 999) alpha,fplus,fcnt
          write(10,999) alpha,fplus,fcnt
      end if

C     Test whether at least mininterp interpolations were made and two 
C     consecutive iterates are much close

      samep = .true.
      do i = 1,nind
         if ( abs( alpha * d(i) ) .gt. 
     +        macheps * max( abs( x(i) ), 1.0d0 ) ) then
            samep = .false.
         end if
      end do

      if ( interp .ge. mininterp .and. samep ) then

C         As this is an abrupt termination then the current point of the 
C         interpolation may be worst than the initial one

C         The previous lines were commented because, as it is been used, 
C         this subroutine must return with the initial point in case of 
C         finding a very small interpolation step. From that initial 
C         point, something different will be tried.

          inform = 6

          if ( iprint .ge. 3 ) then
              write(*, 996) inform
              write(10,996) inform
          end if
  
          go to 500

      end if

C     Else, iterate

      go to 210

C     ==================================================================
C     End of interpolation
C     ==================================================================

C     ==================================================================
C     Return
C     ==================================================================

 500  continue

      return

C     Non-executable statements

 980  format(/,6X,'TN Line search (alphamax= ',1PD11.4,')')
 999  format(6X,'Alpha= ',1PD11.4,' F= ',1PD11.4,' FE= ',I10)
 990  format(6X,'Flag of TN Line search= ',I3,
     +          ' (Armijo-like criterion satisfied)')
 994  format(6X,'Flag of TN Line search= ',I3,
     +          ' (Small functional value, smaller than ',/,
     +       6X,'parameter fmin)')
 996  format(6X,'Flag of TN Line search= ',I3,
     +          ' (Too small step in the interpolation)')
 998  format(6X,'Flag of TN Line search= ',I3,
     +          ' (Too many functional evaluations)')
 1000 format(6X,'Flag of TN Line search = ',I3,' Fatal Error')

      end

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

      subroutine project(n, x, l, u, ml, mleq, lda, A, b, maxit, eps, 
     +lossfeas, epsfeas, csupn, macheps, wi1, wd1, wd2, lwd2, xbest, 
     +iterql, inform)

C     SCALAR ARGUMENTS     
      logical lossfeas
      integer n, ml, mleq, lda, maxit, lwd2, iterql, inform
      double precision eps, epsfeas, csupn, macheps
      
C     ARRAY ARGUMENTS
      integer wi1(ml+n+n)
      double precision x(n), l(n), u(n), A(lda,n), b(ml), wd1(n), 
     +     wd2(lwd2), xbest(n)
      
C     Calculate the projection of x onto the polytope defined by
C     A_j x  = b_j, j = 1, ..., meq
C     A_j x >= b_j, j = meq+1, ..., m
C       l <= x <= u
C
C     This is equivalent to solve the problem
C     
C     min |x - xbar|_2 ^2
C     st  A_j x  = b_j, j = 1, ..., meq
C         A_j x >= b_j, j = meq+1, ..., m
C           l <= x <= u
C
C     On Entry
C      
C     n        integer
C              dimension of x
C
C     x        double precision x(n)
C              vector in R^n to be projected
C
C     l        double precision l(n)
C              lower bounds
C
C     u        double precision u(n)
C              upper bounds
C
C     ml       integer
C              total number of linear constraints (excluding bounds)
C
C     mleq     integer
C              number of linear equality constraints (excluding bounds)     
C      
C     lda      integer
C              leading dimension of matrix A
C      
C     A        double precision A(lda,n)
C              coeficients of linear constraints
C
C     b        double precision b(ml)
C              constant part of linear constraints
C
C     maxit    integer
C              maximum number of iterations allowed
C
C     eps      double precision
C              accuracy to be achieved
C
C     lossfeas logical
C              if a loss of feasibility up to sqrt(epsfeas) is allowed
C              during the computations, lossfeas must be set to TRUE
C              (recommended). In this case, if the final iterate does
C              not satisfy the constraints with the desired precision,
C              we sugest that the user re-run the method using the final
C              point obtained as the initial point, using
C              lossfeas = FALSE
C
C     epsfeas  double precision
C              feasibility tolerance for the sup-norm of the linear
C              constraints
C     
C     macheps double preciosion
C             machine epsilon
C
C     wi1      integer wi(n+n+ml)
C     wd1      double precision wd1(n)
C     wd2      double precision wd2(lwd2)
C     xbest    double precision xbest(n)
C              working vectors
C      
C     lwd2     integer
C              length of wd2. Must be set to, at least, 1.5*n*n+10*n+ml
C     
C     On Return
C      
C     x        double precision x(n)
C              projected vector
C
C     csupn    double precision
C              sup-norm of the constraints at x
C
C     iterql   integer
C              number of calls to QL routine
C
C     inform   integer
C              This output parameter tells what happened in this 
C              subroutine, according to the following conventions:
C
C              0, projection terminated successfully;
C      
C              1, point is feasible with tolerance sqrt(epscsn) (only 
C                 possible if lossfeas = TRUE);
C
C              2, point is infeasible;
C
C             <0, the constraint with index abs(inform) and the
C                 constraints whose indices are iact(k), k = 1, 2, nact, 
C                 are inconsistent
      
C     LOCAL SCALARS
      logical bigeps, smallereps
      integer i, j, nactp
      double precision epstmp, csupnbest, boxsupn, boxsupnbest 

      bigeps       = .false.
      smallereps   = .false.
      csupnbest    = 1.0d+99
      boxsupnbest  = 1.0d+99

C     If there are only bound constraints, there no need to call the
C     quadratic programming solver.
      
      epstmp = eps

C     Call the quadratic programming solver.

      do i = 1, n
         wd1(i) = -x(i)
      end do

 11   continue

      call QL00022(n, ml, mleq, lda, ml+n, A, b, wd1, l, u, x, nactp, 
     +     wi1, maxit, epstmp, inform, wd2, lwd2)

      iterql = iterql + 1

C     Check if the solution is feasible.

      boxsupn = 0.0d0
      do i = 1, n
         boxsupn = max(boxsupn, l(i) - x(i))
         boxsupn = max(boxsupn, x(i) - u(i))
      end do

      do i = 1, ml
         wd2(i) = 0.0d0
      end do
      
      do j = 1, n
         do i = 1, ml
            wd2(i) = wd2(i) + A(i,j) * x(j)
         end do
      end do
      
      csupn = 0.0d0
      
      do i = 1, mleq
         csupn = max(csupn, abs(wd2(i) - b(i)))
      end do

      do i = mleq+1, ml
         csupn = max(csupn, b(i) - wd2(i))
      end do
      
      if (max(boxsupn,csupn) .gt. epsfeas) then
         go to 10
      end if

      go to 20

 10   continue

      if (max(csupn,boxsupn) .lt. max(csupnbest,boxsupnbest)) then
         csupnbest   = csupn
         boxsupnbest = boxsupn

         do i = 1, n
            xbest(i) = x(i)
         end do
      end if

      if (bigeps .and. (inform .lt. 0)) then

         if (lossfeas .and. 
     +        (max(boxsupnbest,csupnbest) .le. sqrt(epsfeas))) then
            
            csupn = csupnbest
            do i = 1, n
               x(i) = xbest(i)
            end do
            inform = 1
         end if

         return
      end if

      if (bigeps .or. (epstmp .lt. macheps) .or. 
     +     (smallereps .and. (inform .ne. 0))) then

         if (lossfeas) then
            if (max(boxsupnbest,csupnbest) .gt. sqrt(epsfeas)) then
               inform = 2
            else
               csupn = csupnbest
               do i = 1, n
                  x(i) = xbest(i)
               end do
               inform = 1
            end if
         else
            inform = 2
         end if

         return

      end if

      if (inform .eq. 0) then
         smallereps = .true.
         epstmp     = epstmp * 1.0d-02
      else
         bigeps = .true.
         epstmp = sqrt(eps)
      end if

      go to 11

 20   continue
      inform = 0

      end

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

      subroutine wfbetra(n, nind, ind, nind2, ind2, x, l, u, ml, mleq, 
     +     lda, A, b, nact, nliact, iact, samefa, gtype, f, g, gz, 
     +     gzsupn, delta, newdelta, mslamb, msrho, mseps, msmaxit, 
     +     phieps, mssig, alpha, delmin, epsg, gamma, lspgmi, lspgma, 
     +     sigma1, sigma2, etaint, mininterp, fmin, lossfeas, epscsn, 
     +     projeps, promaxit, macheps, iprint, ncomp, xeucn2, sts, sty, 
     +     maxfc, ldh, H, diag, ldabar, Abar, tau, wi1, d, dz, xtrial, 
     +     wd1, lwd1, wd2, wd3, wd4, wd5, rbdlu, rbdli, rbdind, triter, 
     +     trfcnt, ispgiter, ispgfcnt, fcnt, gcnt, hcnt, chcnt, iterql, 
     +     ittype, inform)

C     SCALAR ARGUMENTS     
      logical samefa, lossfeas
      integer n, nind, nind2, ml, mleq, lda, nact, nliact, gtype,
     +     msmaxit, mininterp, iprint, ncomp, maxfc, ldh, promaxit, 
     +     ldabar, lwd1, rbdlu, rbdli,  triter, trfcnt, ispgiter, 
     +     ispgfcnt, fcnt, gcnt, hcnt, chcnt, iterql, ittype, inform
      double precision f, gzsupn, delta, newdelta, mslamb, msrho, mseps, 
     +     phieps, mssig, alpha, delmin, epsg, gamma, lspgmi, lspgma, 
     +     sigma1, sigma2, etaint, fmin, epscsn, projeps, macheps, 
     +     xeucn2, sts, sty

C     ARRAY ARGUMENTS
      integer ind(nind), ind2(nind), iact(ml), rbdind(nind+ml), 
     +     wi1(2*nind+ml)
      double precision x(n), l(n), u(n), g(n), gz(nind-nliact), 
     +     H(ldh,n), diag(nind), d(nind), dz(nind-nliact), xtrial(n), 
     +     wd1(lwd1), wd2(n), wd3(n), wd4(n), wd5(ml), A(lda,n), b(ml), 
     +     Abar(ldabar,nliact), tau(nliact)

C     Solves the "unconstrained" minimization subproblem
C
C                         Minimize f(x)
C
C     using a method described in 
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     Algorithm that finds a unconstrained minimizer of objective 
C     function inside the polytope, hits the boundary (obtaining 
C     function decrease), or finds an interior point where the objective 
C     function has sufficient decrease (compared to its value at x).
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 feasible region, 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 
C     feasible region. More-Sorensen algorithm is used to calculate d' too.
C
C     If xtrial lies inside the feasible region, sufficient decrease of 
C     objective function is tested. If it is true, xtrial is accepted as 
C     a solution candidate. If xtrial in on the boundary, inner algorithm 
C     stops and if it is interior, a new iteration begins. If sufficient
C     decrease is not obtained, trust-region radius is decreased and a
C     new quadratic model minimizer is calculated (as in a classical 
C     trust-region algorithm for unconstrained minimization).
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     On Entry
C      
C     n        integer
C              dimension of full space
C
C     nind     integer
C              dimension of reduced space
C
C     ind      integer ind(nind)
C              indices of free variables
C
C     nind2    integer
C              dimension of reduced space
C
C     ind2     integer ind2(nind2)
C              indices of truely free variables
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     ml       integer
C              total number of linear constraints (excluding bounds)
C
C     mleq     integer
C              number of linear equality constraints (excluding bounds)     
C      
C     lda      integer
C              leading dimension of matrix A
C      
C     A        double precision A(lda,n)
C              coeficients of linear constraints
C
C     b        double precision b(ml)
C              constant part of linear constraints
C
C     nact     integer
C              number of active linear constraints
C
C     nliact   integer
C              number of linearly independent active linear
C              constraints
C
C     iact     integer iact(ml)
C              indices of the active linear constraints. The last 
C              m - nact positions of iact store the identifier of the 
C              non-active linear constraints.
C
C     samefa   logical
C              true iff current point is in the same face as the 
C              previous one
C
C     gtype    integer
C              Type of first derivatives calculation according to the 
C              following convention:
C
C              0 = means true first derivatives. 
C
C              1 = means that a finite difference approximation will
C                  be used. 
C      
C     f        double precision
C              objective function value at x
C
C     g        double precision g(n)
C              gradient at x
C
C     gz       double precision gz(nind-nliact)
C              reduced gradient at x (Z^T g)
C     
C     gzsupn   double precision
C              sup-norm of gz
C
C     delta    double precision 
C              trust-region radius
C
C     newdelta double precision
C              trust-region radius is set to the maximum between newdelta 
C              and delta
C     
C     mslamb   double precision
C              value that More-Sorensen algorithm calculates to find 
C              the trust-region subproblem solution (MEQB)
C
C     msrho    double precision
C              distance from the boundary (to prevent that the error 
C              in the length of step calculated by More-Sorensen 
C              algorithm make the solution candidate lie outside the 
C              feasible region)
C
C     mseps    double precision
C              tolerance for More-Sorensen algorithm (MEQB)
C
C     msmaxit  integer
C              maximum allowed number of MEQB iterations
C      
C     phieps   double precision
C              allowed error in comparing the quadratic model value to 
C              zero
C
C     mssig    double precision
C              allowed error to trust-region subproblem solution 
C              (MEQB)
C
C     alpha    double precision
C              sufficient decrease occurs when ared >= alpha*pred
C
C     delmin   double precision
C              minimum value for trust-region radius (delta) in the 
C              beginning of each iteration
C
C     epsg     double precision
C              allowed error for projected gradient norm
C
C     gamma    double precision
C              Armijo condition constant (SPG)
C
C     lspgmi   double precision
C              lower bound on spectral step (SPG)
C
C     lspgma   double precision
C              upper bound on spectral step (SPG)
C
C     sigma1   double precision
C              safeguard for line search (lower) (SPG)
C
C     sigma2   double precision
C              safeguard for line search (upper) (SPG)
C
C     etaint   double precision
C              constant for the interpolation. See the description of
C              sigma1 and sigma2 above. Sometimes we take as a new 
C              trial step the previous one divided by etaint
C
C     mininterp integer
C              constant for testing if, after having made at least 
C              mininterp interpolations, the steplength is so small. In 
C              that case failure of the line search is declared (may be 
C              the direction is not a descent direction due to an error 
C              in the gradient calculations) 
C
C     fmin     double precision
C              function value for the stopping criteria f <= fmin
C
C              There is a stopping criterion that stops BETRA if a 
C              point with a functional value smaller than fmin is found. 
C              The idea behind this stopping criterion is to stop the 
C              method if the objective function is not bounded from 
C              bellow.
C
C     lossfeas logical
C              if a loss of feasibility up to sqrt(epsfeas) is allowed
C              during the computations, lossfeas must be set to TRUE
C              (recommended). In this case, if the final iterate does
C              not satisfy the constraints with the desired precision,
C              we sugest that the user re-run the method using the final
C              point obtained as the initial point, using
C              lossfeas = FALSE
C
C     epscsn   double precision
C              feasibility tolerance for the sup-norm of the linear
C              constraints
C     
C     macheps  double precision
C              macheps is the smallest positive number such that
C              1 + macheps is not equal to 1
C
C     projeps  double precision
C              precision used in projection routine
C
C     promaxit integer
C              maximum allowed number of iterations of QL routine used 
C              in projection
C
C     iprint   integer
C              Commands printing. Nothing is printed if iprint is 
C              smaller than 3.
C
C     ncomp    integer,         
C              every time a vector is printed, just its first ncomp
C              component will be displayed.
C
C     xeucn2   double precision
C              x squared Euclidian norm
C
C     sts      double precision
C              product s^T s, where s = x_{k+1} - x_k
C
C     sty      double precision
C              product s^T y, where y = g_{k+1} - g_k and s as above
C      
C     maxfc    integer
C              maximum allowed number of function evaluations
C
C     ldh      integer
C              leading dimension of matrix H
C
C     H        double precision H(ldh,n)
C              working matrix
C
C     ldabar   integer
C              leading dimension of matrix Abar
C
C     Abar     double precision Abar(ldabar,ml)
C              hold the LQ factorization of the matrix whose columns
C              correspond to the active linear constraints, after 
C              eliminating the elements correnponding to fixed variables
C
C     tau      double precision tau(nliact)
C              used to retrieve the columns of Q from Abar
C
C     wi1      integer wi1(2*nind+ml)
C              working vector
C
C     d        double precision d(nind)
C     dz       double precision dz(nind-nliact)
C     xtrial   double precision xtrial(n)
C     diag     double precision diag(nind)     
C     wd1      double precision wd1(lwd1)
C     wd2      double precision wd2(n)
C     wd3      double precision wd3(n)
C     wd4      double precision wd4(n)
C     wd5      double precision wd5(ml)
C              working vectors 
C      
C     On Return
C      
C     x        double precision x(n)
C              solution candidate, with inform as described bellow
C
C     f        double precision
C              objective function value at x
C
C     g        double precision g(n)
C              gradient at x
C
C     newdelta double precision
C              when the trust-region radius delta is decreased so that 
C              the point x + d fit the current face, newdelta is set to 
C              the previous value of delta. Otherwise, it is set to 0
C
C     rbdlu    integer
C              number of variables that reached a lower or upper 
C              bound
C
C     rbdli    integer
C              total number of new active constraints. rbdli-rbdlu
C              is the number of linear constraints that are now 
C              satisfied by equality
C
C     rbdind   integer rbdind(n+ml)
C              indices of bound and linear constraints that are 
C              satisfied by equality at the new point x. That is, 
C              indices of the constraints to be added to the active set)
C
C     triter   integer
C              number of trust-region iterations
C
C     trfcnt   integer
C              number of function evaluations performed by trust-region 
C              iterations
C
C     ispgiter integer
C              number of inner SPG iterations
C
C     ispgfcnt integer
C              number of function evaluations performed by inner SPG
C
C     fcnt     integer
C              total number of function evaluations
C
C     gcnt     integer
C              total number of gradient evaluations
C
C     hcnt     integer
C              total number of Hessian evaluations
C
C     chcnt    integer
C              number of Cholesky decompositions
C
C     delta    double precision
C              updated trut-region radius
C
C     mslamb   double precision
C              updated value for next iteration (see entry parameter)
C
C     iterql   integer
C              number of calls to QL routine (used in projection)
C
C     ittype   integer
C              iteration type: 
C              7, for inner SPG;
C              8, for trust-region;
C
C     inform   integer
C              This output parameter tells what happened in this 
C              subroutine, according to the following conventions:
C      
C              0 = if sufficient decrease of function is achieved;
C     
C              1 = if x is close to the boundary and is a first-order 
C                  stationary point;
C
C              2 = if x is a second-order stationary point;
C
C              3 = if x hit the boundary;
C
C              4 = if a very small function value is achieved;
C     
C              5 = if trust-region radius is too small;
C
C              6 = if either the search direction or the step lenght if 
C                  too small;
C
C              8 = if maximum allowed number of function evaluations is 
C                  achieved;
C
C             10 = either the new point x+d would be infeasible or a 
C                  problem in projection subroutine prevented d from 
C                  being calculated. x is returned;
C
C            -90 = means that subroutine evalf retuned an error flag;
C
C            -92 = means that subroutine evalg retuned an error flag;
C
C            -94 = means that subroutine evalh retuned an error flag;

C     LOCAL SCALARS
      logical samep, pd, checkfeas
      integer i, ii, j, jj, jjj, index, infotmp, fcntprev, nred
      double precision dbound, tmax, pred, ared, deucn, tmp, phi, 
     +     ftrial, lamspg, ad, ax

C     Print presentation information

      if (iprint .ge. 3) then
         write(*, 980)
         write(10,980)
      end if

      nred = nind - nliact

      if (.not. samefa) then
         delta = max(delta, newdelta)
      end if
      delta = max(delta, delmin)

      newdelta  = 0.0d0
      checkfeas = .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
C             (set of constraints).

      dbound = 1.0d+30

      do i = 1, nind2
         ii = ind2(i)
         dbound = min(dbound, x(ii) - l(ii))
      end do

      do i = 1, nind2
         ii = ind2(i)
         dbound = min(dbound, u(ii) - x(ii))
      end do

C     Look to the linear inequality constraints

      call expand(nind, ind, n, x)

      do i = 1, ml-nact
         wd5(i) = 0.0d0
      end do
      
      do j = 1, n
         do i = nact+1, ml
            ii = iact(i)
            
            wd5(i-nact) = wd5(i-nact) + A(ii,j) * x(j) 
         end do
      end do
      
      call shrink(nind, ind, n, x)

      do i = nact+1, ml
         ii = iact(i)
         dbound = min(dbound, wd5(i-nact) - b(ii))
      end do

C     ==================================================================
C     Close to the boundary: performe inner SPG iteration
C     ==================================================================
      
C     step 2: close to the boundary: if the gradient is null then 
C             algorithm stops. Else, perform an inner SPG iteration.

      if (dbound .lt. 2.0d0 * delmin) then

         if (gzsupn .le. epsg) then
            inform = 1
            
            if (iprint .ge. 3) then
               write(*, 983) inform
               write(10,983) inform
            end if
                        
            return
         end if
         
         ittype = 7

C        Compute spectral steplength

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

         fcntprev = fcnt

C        Shrink columns of A (like x).

         call shrinkcol(n, ml, nind, ind, lda, A)

C        Shrink x, l, u, A to the space of really free variable
C        (using nind2 and ind2).
 
         call shrink(nind2, ind2, nind, x)
         call shrink(nind2, ind2, nind, g)
         call shrink(nind2, ind2, nind, l)
         call shrink(nind2, ind2, nind, u)
         call shrinkcol(nind, ml, nind2, ind2, lda, A)
         
         call ispgls(n, nind, ind, nind2, ind2, x, f, g, l, u, ml, mleq, 
     +        lda, A, b, nact, iact, lamspg, etaint, mininterp, fmin, 
     +        maxfc, iprint, xtrial, tmax, d, gamma, sigma1, sigma2, 
     +        lossfeas, epscsn, projeps, promaxit, macheps, wi1, wd2, 
     +        wd1, lwd1, wd3, wd5, fcnt, iterql, inform)

         ispgfcnt = ispgfcnt + (fcnt - fcntprev)
         
C        Expand x, l, u, A to the space of free variable (given by nind
C        and ind).

         do i = nind2+1, nind
            d(i) = 0.0d0
         end do

         call expand(nind2, ind2, nind, xtrial)
         call expand(nind2, ind2, nind, d)
         call expand(nind2, ind2, nind, x)
         call expand(nind2, ind2, nind, g)
         call expand(nind2, ind2, nind, l)
         call expand(nind2, ind2, nind, u)
         call expandcol(nind, ml, nind2, ind2, lda, A)
         
C        Expand columns of A (like x).

         call expandcol(n, ml, nind, ind, lda, A)
         
         if (inform .lt. 0) then
            if (iprint .ge. 3) then
               write(*, 989) inform
               write(10,989) inform
            end if
            
            return
         end if

         ispgiter = ispgiter + 1
         
C        Compute the gradient at the new iterate

         infotmp = inform
         
         call calcgr(nind, ind, x, n, x, g, gtype, macheps, inform)
         gcnt = gcnt + 1
         
         if (inform .lt. 0) then
            if (iprint .ge. 3) then
               write(*, 989) inform
               write(10,989) inform
            end if
            
            return
         end if
            
         inform = infotmp

         if (inform .eq. 6) then
            if (iprint .ge. 3) then
               write(*, 991) inform
               write(10,991) inform
            end if
            
            return
         
         elseif (inform .eq. 8) then
            if (iprint .ge. 3) then
               write(*, 987) inform
               write(10,987) inform
            end if
            
            return
            
         elseif (inform .eq. 4) then
            if (iprint .ge. 3) then
               write(*, 988) inform
               write(10,988) inform
            end if
            
            return

         elseif (inform .eq. 10) then
            return

         else
            go to 7
         end if
         
      end if

C     ==================================================================
C     Far from the boundary: performe trust-region iteration
C     ==================================================================
      
      ittype = 8

      triter = triter + 1

C     step 3: far from the boundary, solve trust-region subproblem. 
C             Evaluate function Hessian at x.

      call calchz(n, nind, ind, x, x, nliact, ldabar, Abar, tau, 
     +     macheps, wd2, wd3, wd4, ldh, H, diag, inform)      

      hcnt = hcnt + 1
            
      if (inform .lt. 0) then
         if (iprint .ge. 3) then
            write(*, 989) inform
            write(10,989) inform
         end if
         
         return
      end if
      
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.

 4    continue

c      if (delta .lt. macheps**(2.0d0/3.0d0)) then
      if (delta .lt. macheps * max(1.0d0,sqrt(xeucn2))) then
         inform = 5
         
         if (iprint .ge. 3) then
            write(*, 986) inform, delta
            write(10,986) inform, delta
         end if
         
         return
      end if
      
      if (.not. samefa) then
         mslamb = 0.0d0
      end if

      call MEQB(nred, gz, ldh, H, diag, delta, mssig, 0.0d0, mseps, 
     +     macheps, msmaxit, iprint, wd2, wd3, wd4, mslamb, pd, dz, 
     +     chcnt, inform)

C     If maximum allowed number of MEQB iterations is achieved, another
C     direction d is calculated.

      if (inform .eq. 5) then 

         if (iprint .ge. 3) then
            write(*, *) '     Since the direction calculation failed, '
            write(*, *) '     dogleg direction will be computed'
            write(10,*) '     Since the direction calculation failed, '
            write(10,*) '     dogleg direction will be computed'
         end if

         call dogleg(nred, gz, ldh, H, diag, pd, delta, macheps, wd2, 
     +        dz, inform)

      end if

C     If both internal gradient and Hessian matrix are null, subroutines 
C     MEQB and dogleg stop with inform = 0 and then the inner algorithm 
C     stops declaring "second-order stationary point".

      if (inform .eq. 0) then
         inform = 2

         if (iprint .ge. 3) then
            write(*, 984) inform
            write(10,984) inform
         end if
         
         return
      end if

C     Evaluate the quadratic model of the objective function at d.

      call quad(nred, dz, gz, ldh, H, diag, wd2, 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. (gzsupn .le. epsg)) then

         inform = 2
         
         if (iprint .ge. 3) then
            write(*, 984) inform
            write(10,984) inform
         end if
         
         return
      end if

C     Calculate predicted decrease of objective function
      
      pred = abs(phi)

C     Calculate direction d = Z dz and adjust it.

      call multZ(nind, nliact, ldabar, Abar, tau, dz, d, macheps)

C     Print direction

      if (iprint .ge. 3) then
          write(*, 993) min0(nind,ncomp),(d(i),i=1,min0(nind,ncomp))
          write(10,993) min0(nind,ncomp),(d(i),i=1,min0(nind,ncomp))
      end if

C     Calculate d Euclidian-norm
      
      deucn = 0.0d0
      do i = 1, nind
         deucn = deucn + d(i)**2
      end do
      deucn = dsqrt(deucn)

C     Calculate point xtrial = x + d.

      do i = 1, nind
         xtrial(i) = x(i) + d(i)
      end do

C     If the new point x + Z dz is too close to the previous point x, 
C     inner algorithm stops

      samep = .true.
      do i = 1, nind
         if (abs(d(i)) .gt. macheps * max(abs(xtrial(i)),1.0d0)) then
            samep = .false.
         end if
      end do
      
      if (samep) then
         inform = 6
         
         if (iprint .ge. 3) then
            write(*, 991) inform
            write(10,991) inform
         end if
         
         return
      end if     

C     Verify if xtrial is inside de feasible region. If not, interior is 
C     set to false and tmax is set to the biggest positive scalar such 
C     that x + tmax*d is inside the feasible region.
 
      tmax  = 1.0d0
      rbdlu = 0
         
      do i = 1, nind2
         ii = ind2(i)
         
         if (abs(d(ii)) .ge. macheps * max(abs(x(ii)), 1.0d0)) then
            if (xtrial(ii) .le. l(ii)) then
               tmp = (l(ii) - x(ii)) / d(ii)
               if (tmp .lt. tmax - macheps * max(tmax, 1.0d0)) then
                  tmax = tmp
                  rbdlu = 1
                  rbdind(rbdlu) = ii
               else 
                  if (tmp .le. tmax + macheps * max(tmax, 1.0d0)) then
                     rbdlu = rbdlu + 1
                     rbdind(rbdlu) = ii
                  end if
               end if
            else 
               if (xtrial(ii) .ge. u(ii)) then
                  tmp = (u(ii) - x(ii)) / d(ii)
                  if (tmp .lt. tmax - macheps * max(tmax, 1.0d0)) then
                     tmax = tmp
                     rbdlu = 1
                     rbdind(rbdlu) = ii + n
                  else
                     if (tmp .le. tmax+ macheps * max(tmax, 1.0d0)) then
                        rbdlu = rbdlu + 1
                        rbdind(rbdlu) = ii + n
                     end if
                  end if
               end if
            end if
         end if
      end do

C     Look to the linear inequality constraints
         
      rbdli = rbdlu

      call expand(nind, ind, n, x)

      do i = 1, ml-nact
         wd5(i) = 0.0d0
      end do
      
      do j = 1, n
         do i = nact+1, ml
            ii = iact(i)
            
            wd5(i-nact) = wd5(i-nact) + A(ii,j) * x(j) 
         end do
      end do
      
      call shrink(nind, ind, n, x)

      do i = nact+1, ml
         ii = iact(i)        
         ad = 0.0d0
         do j = 1, nind2
            jj  = ind2(j)
            jjj = ind(jj)
            ad = ad + A(ii,jjj) * d(jj)
         end do

         ax = wd5(i-nact)
         
         if (abs(ad) .ge. macheps * max(abs(ax), 1.0d0)) then
            
            if (ax + ad .le. b(ii)) then
               tmp = (b(ii) - ax) / ad
               
               if (tmp .lt. tmax - macheps * max(tmax, 1.0d0)) then
                  tmax  = tmp
                  rbdlu = 0
                  rbdli = 1
                  rbdind(rbdli) = i
               else
                  if (tmp .le. tmax + macheps * max(tmax, 1.0d0)) then
                     rbdli = rbdli + 1
                     rbdind(rbdli) = i
                  end if
               end if
            end if
         end if
      end do

C     ==================================================================
C     Point on the boundary
C     ==================================================================      
      
C     If xtrial is not interior to the polytope, xtrial = x + d is 
C     replaced by xtrial = x + tmax*d. Now xtrial is definitely interior. 
C     Actually, it is in the boundary. If the objective function
C     decreases in xtrial, the inner algorithm stops with xtrial as a 
C     solution. Otherwise, a new trust-region radius delta is chosen 
C     (smaller than dbound) and a new quadratic model minimizer is 
C     calculated (which is necessarily interior because of the choice 
C     of delta).

      if (rbdli .gt. 0) then

         if (iprint .ge. 3) then
            write(*, *) '     x+d is not interior to the feasible set'
            write(10,*) '     x+d is not interior to the feasible set'
         end if

         do i = 1, nind
            xtrial(i) = x(i) + tmax * d(i)
         end do
         
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, rbdlu
            index = rbdind(i)
            if (index .gt. n) then
               xtrial(index-n) = u(index-n)
            else
               xtrial(index) = l(index)
            end if
         end do

C        Check if new point xtrial is feasible. If it is infeasible, due 
C        to numerical errors, trust-region radius delta is decreased and 
C        new direction is computed

         if (checkfeas) then
            do i = 1, ml
               wd5(i) = 0.0d0
            end do
            
            do i = nind+1, n
               xtrial(i) = x(i)
            end do
            
            call expand(nind, ind, n, xtrial)
            
            do j = 1, n
               do i = 1, ml
                  wd5(i) = wd5(i) + A(i,j) * xtrial(j)
               end do
            end do
            
            call shrink(nind, ind, n, xtrial)
            
            if (lossfeas) then
               do i = 1, mleq
                  if (abs(wd5(i) - b(i)) .gt. sqrt(epscsn)) then
                     
                     if (iprint .ge. 3) then
                        write(*, *) '     x+d is infeasible'
                        write(10,*) '     x+d is infeasible'
                     end if
                     
                     inform = 10
                     return
                  end if
               end do
               
               do i = mleq+1, ml
                  if (b(i) - wd5(i) .gt. sqrt(epscsn)) then
                     
                     if (iprint .ge. 3) then
                        write(*, *) '     x+d is infeasible'
                        write(10,*) '     x+d is infeasible'
                     end if
                     
                     inform = 10
                     return
                  end if
               end do
            else
               do i = 1, mleq
                  if (abs(wd5(i) - b(i)) .gt. epscsn) then
                     
                     if (iprint .ge. 3) then
                        write(*, *) '     x+d is infeasible'
                        write(10,*) '     x+d is infeasible'
                     end if
                     
                     inform = 10
                     return
                  end if
               end do
               
               do i = mleq+1, ml
                  if (b(i) - wd5(i) .gt. epscsn) then
                     
                     if (iprint .ge. 3) then
                        write(*, *) '     x+d is infeasible'
                        write(10,*) '     x+d is infeasible'
                     end if
                     
                     inform = 10
                     return
                  end if
               end do
            end if
            
            checkfeas = .false.
         end if

C        Compute functional value at xtrial

         call calcobj(nind, ind, xtrial, n, x, ftrial, inform)
         fcnt   = fcnt + 1
         trfcnt = trfcnt + 1

         if (inform .lt. 0) then

            if (iprint .ge. 3) then
               write(*, *) '     f(x+d) is undefined'
               write(10,*) '     f(x+d) is undefined'
            end if
            
            delta  = 2.5d-1 * deucn
            triter = triter + 1
            go to 4   
         end if

C        Print functional value

         if (iprint .ge. 3) then
            write(*, 994) delta, ftrial, fcnt
            write(10,994) delta, ftrial, fcnt
         end if

C        Test whether the number of functional evaluations is exhausted

         if (fcnt .ge. maxfc) then
            
            do i = 1, nind
               x(i) = xtrial(i)
            end do
            
            f = ftrial

            call calcgr(nind, ind, x, n, x, g, gtype, macheps, inform)
            gcnt = gcnt + 1

            if (inform .lt. 0) then
               if (iprint .ge. 3) then
                  write(*, 989) inform
                  write(10,989) inform
               end if
               
            else
               inform = 8

               if (iprint .ge. 3) then
                  write(*, 987) inform
                  write(10,987) inform
               end if
            end if
            
            return
         end if

C        Test whether f is very small
      
         if (ftrial .le. fmin) then
            
            do i = 1, nind
               x(i) = xtrial(i)
            end do
            
            f = ftrial
            
            call calcgr(nind, ind, x, n, x, g, gtype, macheps, inform)
            gcnt = gcnt + 1

            if (inform .lt. 0) then
               if (iprint .ge. 3) then
                  write(*, 989) inform
                  write(10,989) inform
               end if
            else
               inform = 4

               if (iprint .ge. 3) then
                  write(*, 988) inform
                  write(10,988) inform
               end if
            end if
            
            return
         end if      
         
C        Test if function value decreases at xtrial
        
         if ((ftrial .le. f) .or. 
     +        ((deucn .le. macheps**(2.0d0/3.0d0) * sqrt(xeucn2)) .and.
     +        (ftrial .le. f + macheps**(2.0d0/3.0d0) * abs(f)))) then

            if (iprint .ge. 3) then
               write(*, *) '     f(x+d) < f(x), x+d is accepted'
               write(10,*) '     f(x+d) < f(x), x+d is accepted'
            end if

C           Update the trust-region radius (which may or may not be 
C           used)
               
            delta = 2.0d0 * delta

C           Calculate actual reduction of objective function

            ared = f - ftrial

C           Update x, f and g.
            
            do i = 1, nind
               x(i) = xtrial(i)
            end do
               
            f = ftrial

            call calcgr(nind, ind, x, n, x, g, gtype, macheps, inform)
            gcnt = gcnt + 1

            if (inform .lt. 0) then
               if (iprint .ge. 3) then
                  write(*, 989) inform
                  write(10,989) inform
               end if
               
               return
            end if
            
            inform = 3
            
            go to 8
         else
            newdelta = delta
            tmp = delmin + msrho * ((dbound / (1.0d0 + mssig)) - delmin)
            delta    = max(delmin, tmp)
            triter   = triter + 1
            go to 4
         end if
      end if

C     ==================================================================
C     Point interior to the feasible region
C     ==================================================================
      
C     step 5: in this case xtrial is inside the polytope. Acceptance or
C             rejection of the trust-region subproblem solution.

C     Check if new point xtrial is feasible. If it is infeasible, due 
C     to numerical errors, trust-region radius delta is decreased and 
C     new direction is computed
      
      if (checkfeas) then
         do i = 1, ml
            wd5(i) = 0.0d0
         end do
         
         do i = nind+1, n
            xtrial(i) = x(i)
         end do
         
         call expand(nind, ind, n, xtrial)
         
         do j = 1, n
            do i = 1, ml
               wd5(i) = wd5(i) + A(i,j) * xtrial(j)
            end do
         end do
         
         call shrink(nind, ind, n, xtrial)
         
         if (lossfeas) then
            do i = 1, mleq
               if (abs(wd5(i) - b(i)) .gt. sqrt(epscsn)) then
                  
                  if (iprint .ge. 3) then
                     write(*, *) '     x+d is infeasible'
                     write(10,*) '     x+d is infeasible'
                  end if
                  
                  inform = 10
                  return
               end if
            end do
            
            do i = mleq+1, ml
               if (b(i) - wd5(i) .gt. sqrt(epscsn)) then
                  
                  if (iprint .ge. 3) then
                     write(*, *) '     x+d is infeasible'
                     write(10,*) '     x+d is infeasible'
                  end if
                  
                  inform = 10
                  return
               end if
            end do
         else
            do i = 1, mleq
               if (abs(wd5(i) - b(i)) .gt. epscsn) then
                  
                  if (iprint .ge. 3) then
                     write(*, *) '     x+d is infeasible'
                     write(10,*) '     x+d is infeasible'
                  end if
                  
                  inform = 10
                  return
               end if
            end do
            
            do i = mleq+1, ml
               if (b(i) - wd5(i) .gt. epscsn) then
                  
                  if (iprint .ge. 3) then
                     write(*, *) '     x+d is infeasible'
                     write(10,*) '     x+d is infeasible'
                  end if
                  
                  inform = 10
                  return
               end if
            end do
         end if
         
         checkfeas = .false.
      end if

C     Compute functional value at xtrial

      call calcobj(nind, ind, xtrial, n, x, ftrial, inform)
      fcnt   = fcnt + 1
      trfcnt = trfcnt + 1

      if (inform .lt. 0) then

         if (iprint .ge. 3) then
            write(*, *) '     f(x+d) is undefined'
            write(10,*) '     f(x+d) is undefined'
         end if
         
         delta  = 2.5d-1 * deucn
         triter = triter + 1
         go to 4   
      end if

C     Print functional value

      if (iprint .ge. 3) then
         write(*, 994) delta, ftrial, fcnt
         write(10,994) delta, ftrial, fcnt
      end if

C     Test whether the number of functional evaluations is exhausted
      
      if (fcnt .ge. maxfc) then
         do i = 1, nind
            x(i) = xtrial(i)
         end do

         f = ftrial

         call calcgr(nind, ind, x, n, x, g, gtype, macheps, inform)
         gcnt = gcnt + 1

         if (inform .lt. 0) then
            if (iprint .ge. 3) then
               write(*, 989) inform
               write(10,989) inform
            end if
         else
            inform = 8
            
            if (iprint .ge. 3) then
               write(*, 987) inform
               write(10,987) inform
            end if
         end if

         return
      end if

C     Test whether f is very small
      
      if (ftrial .le. fmin) then
         
         do i = 1, nind
            x(i) = xtrial(i)
         end do
         
         f = ftrial
         
         call calcgr(nind, ind, x, n, x, g, gtype, macheps, inform)
         gcnt = gcnt + 1

         if (inform .lt. 0) then
            if (iprint .ge. 3) then
               write(*, 989) inform
               write(10,989) inform
            end if
         else
            inform = 4

            if (iprint .ge. 3) then
               write(*, 988) inform
               write(10,988) inform
            end if
         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 (iprint .ge. 3) then
         write(*, 981) deucn, pred, ared
         write(10,981) deucn, pred, ared
      end if

      if ((deucn .le. macheps**(2.0d0/3.0d0) * sqrt(xeucn2)) .and.
     +     (ared .le. macheps**(2.0d0/3.0d0) * abs(f))) then
         
         do i = 1, nind
            x(i) = xtrial(i)
         end do
         
         f = ftrial
         
         call calcgr(nind, ind, x, n, x, g, gtype, macheps, inform)
         gcnt = gcnt + 1
         
         if (inform .lt. 0) then
            if (iprint .ge. 3) then
               write(*, 992) inform
               write(10,992) inform
            end if
            
            return
         end if
         
         go to 8
      end if

      if (((pred .gt. phieps) .and. (ared .lt. alpha*pred)) .or.
     +     ((pred .le. phieps) .and. (f .lt. ftrial))) then

         delta  = 2.5d-1 * deucn
         triter = triter + 1
         go to 4
      end if
      
C     Point xtrial is accepted.

      do i = 1, nind
         x(i) = xtrial(i)
      end do
      
      f = ftrial
      
      call calcgr(nind, ind, x, n, x, g, gtype, macheps, inform)
      gcnt = gcnt + 1
      
      if (inform .lt. 0) then
         if (iprint .ge. 3) then
            write(*, 989) inform
            write(10,989) inform
         end if
         
         return
      end if
      
      go to 8

C     ==================================================================
C     Prepare for next call to this routine
C     ==================================================================
      
C     If new point x is in the boundary, the inner algorithm stops
C     and returns x as solution.
      
 7    rbdlu = 0

      do i = 1, nind2
         ii = ind2(i)
         
         if (x(ii) .le. l(ii) + macheps * max(abs(l(ii)), 1.0d0)) then
            x(ii) = l(ii)
            rbdlu = rbdlu + 1
            rbdind(rbdlu) = ii
         else if (x(ii) .ge. u(ii)-macheps*max(abs(u(ii)), 1.0d0)) then
            x(ii) = u(ii)
            rbdlu = rbdlu + 1
            rbdind(rbdlu) = ii + n
         end if
      end do

C     Look to the linear inequality constraints
      
      rbdli = rbdlu

      call expand(nind, ind, n, x)         
            
      do i = 1, ml-nact
         wd5(i) = 0.0d0
      end do

      do j = 1, n
         do i = nact+1, ml
            ii = iact(i)
                  
            wd5(i-nact) = wd5(i-nact) + A(ii,j) * x(j) 
         end do
      end do

      do i = nact+1, ml
         ii = iact(i)

         if (abs(wd5(i-nact)-b(ii)) .le. epscsn) then
            rbdli = rbdli + 1
            rbdind(rbdli) = i
         end if
      end do
      
      call shrink(nind, ind, n, x)    
      
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).

 8    if (ittype .eq. 8) then
         if (ared .lt. 2.5d-1 * pred) then
            delta = max(2.5d-1 * deucn, delmin)        
         else
            if ((ared .ge. 0.5d0 * pred) .and.
     +           (deucn .ge. delta - macheps**(2.0d0/3.0d0) *
     +           max(delta, 1.0d0))) then
               delta = max(2.0d0 * delta, delmin)
            else
               delta = max(delta, delmin)
            end if
         end if
      end if

C     Print final information

      if (rbdli .gt. 0) then
         inform = 3
         
         if (iprint .ge. 3) then
            write(*, 985) inform
            write(10,985) inform
         end if
      else
         inform = 0

         if (iprint .ge. 3) then
            write(*, 982) inform
            write(10,982) inform
         end if
      end if

C     Non-executable statements
      
 980  format(/,6x,'inner BETRA iteration')
 981  format(6x,'dnorm= ',1PD11.4,' pred= ',1PD11.4,' ared= ',1PD11.4)
 982  format(6X,'Flag of inner BETRA = ',I3,
     +       6X,' (sufficient decrease of function)')
 983  format(6X, 'Flag of inner BETRA = ',I3,
     +       6X,' (first-order stationary point close to the boundary)')
 984  format(6x,'Flag of inner BETRA = ',I3,
     +           ' (second-order stationary point)')
 985  format(6x,'Flag of inner BETRA = ',I3,
     +          ' (point on the boundary)')      
 986  format(6x,'Flag of inner BETRA = ',I3,
     +          ' (trust-region radius delta= ',1PD11.4, ' too small)')
 987  format(6x,'Flag of inner BETRA = ',I3,
     +          ' (Too many functional evaluations)')
 988  format(6x,'Flag of inner BETRA = ',I3,
     +          ' (Small functional value, smaller than ',/,
     +       6X,'  parameter fmin)')
 989  format(6X,'Flag of inner BETRA = ',I3,' Fatal Error')
 991  format(6X,'Flag of inner BETRA = ',I3,
     +       6X,' (Search direction too small)')      
 992  format(6X,'Flag of inner BETRA = ',I3,
     +          '(PROVISORIO)')
 993  format(/,6X,'Computed direction (first ',I6, ' components): ',/,
     +          1(6X,6(1PD11.4,1X)))
 994  format(/,6X,'delta= ',1PD11.4,' F= ',1PD11.4,' FE= ',I10)

      end

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

      subroutine shrinkcol(n, m, nind, ind, ldh, H)

C     SCALAR ARGUMENTS       
      integer n, m, nind, ldh

C     ARRAY ARGUMENTS       
      integer ind(nind)
      double precision H(ldh,n)

C     Reduce columns of matriz H from space of dimension n to a space
C     of dimension nind (space of free variables). To do so, in the
C     first nind components of each column of H are stored the values
C     corresponding to the free variables and in the last n - nind
C     components are stored the values of the fixed variables.
C
C     On entry
C
C     n        integer
C              dimension of full space
C     
C     m        integer
C              number of rows of H
C     
C     nind     integer
C              dimension of reduced space
C
C     ind      integer ind(nind)
C              free variables indices on original space
C
C     ldh     integer
C              leading dimension of H
C    
C     H        double precision H(ldh,n)
C              matrix whose columns are to be reduced to a space of
C              smaller dimension (reduced space)
C     
C     On Return
C      
C     H        double precision H(ldh,n)
C              matrix whose columns are reduced to a space of smaller
C              dimension (reduced space). The first nind columns
C              correspond to the free variable values and the last
C              n - nind correspond to the fixed variable values

C     LOCAL SCALARS      
      integer i, j, jj
      double precision tmp

      if (m .eq. 0) then
         return
      end if

      do j = 1, nind
         jj = ind(j)

         if (j .ne. jj) then
            do i = 1, m
               tmp     = H(i,j)
               H(i,j)  = H(i,jj)
               H(i,jj) = tmp
            end do
         end if
      end do
           
      end

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

      subroutine shrinkrow(n, nind, ind, ldh, H)

C     SCALAR ARGUMENTS       
      integer n, nind, ldh

C     ARRAY ARGUMENTS       
      integer ind(nind)
      double precision H(ldh,n)

C     Reduce rows of matriz H from space of dimension n to a space
C     of dimension nind (space of free variables). To do so, in the
C     first nind components of each row of H are stored the values
C     corresponding to the free variables and in the last n - nind
C     components are stored the values of the fixed variables. 
C
C     On entry
C
C     n        integer
C              dimension of full space
C     
C     nind     integer
C              dimension of reduced space
C
C     ind      integer ind(nind)
C              free variables indices on original space
C
C     ldh      integer
C              leading dimension of H
C    
C     H        double precision H(ldh,n)
C              matrix whose rows are to be reduced to a space of
C              smaller dimension (reduced space)
C     
C     On Return
C      
C     H        double precision H(ldh,n)
C              matrix whose rows are reduced to a space of smaller
C              dimension (reduced space). The first nind rows
C              correspond to the free variable values and the last
C              n - nind correspond to the fixed variable values

C     LOCAL SCALARS      
      integer i, ii, j, jj
      double precision tmp

      do j = 1, nind
         jj = ind(j)

         do i = 1, nind
            ii = ind(i)
            
            if (i .ne. ii) then
               tmp      = H(i,jj)
               H(i,jj)  = H(ii,jj)
               H(ii,jj) = tmp
            end if
         end do
      end do

      end             

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

      subroutine expandcol(n, m, nind, ind, ldh, H)

C     SCALAR ARGUMENTS       
      integer n, m, nind, ldh
      
C     ARRAY ARGUMENTS 
      integer ind(nind)
      double precision H(ldh,n)

C     Expand columns of matriz H from space of dimension nind to a
C     space of dimension n. This is done by rearranging columns of H
C     so they are exactly the way they were before using the subroutine
C     shrinkcol.
C     
C     On Entry
C     
C     n        integer
C              dimension of full space
C
C     m        integer
C              number of rows of H
C     
C     nind     integer
C              dimension of reduced space
C
C     ind      integer ind(nind)
C              free variables indices on original space
C
C     ldh      integer
C              leading dimension of H
C    
C     H        double precision H(ldh,n)
C              matrix whose columns are to be expanded to a space of
C              higher dimension (full space)
C     
C     On Return
C      
C     H        double precision H(ldh,n)
C              matrix whose columns are expanded to a space of higher
C              dimension (full space)
      
C     LOCAL SCALARS
      integer i, j, jj
      double precision tmp

      if (m .eq. 0) then
         return
      end if

      do j = nind, 1, -1
         jj = ind(j)

         if (j .ne. jj) then
            do i = 1, m
               tmp     = H(i,j)
               H(i,j)  = H(i,jj)
               H(i,jj) = tmp
            end do
         end if
      end do
      
      end       

C     *****************************************************************
C     *****************************************************************
      
      subroutine calchz(n, nind, ind, x, xc, nliact, ldabar, Abar, 
     +     tau, macheps, wd1, wd2, wd3, ldh, H, diag, inform)      

C     SCALAR ARGUMENTS
      integer n, nind, nliact, ldabar, ldh, inform
      double precision macheps

C     ARRAY ARGUMENTS
      integer ind(nind)
      double precision x(n), xc(n), Abar(ldabar,nliact), tau(nliact), 
     +     wd1(n), wd2(n), wd3(n), H(ldh,n), diag(nind)
      
C     Evaluate Hessian H at x and compute Z^T H Z. Because x is in the 
C     reduced space of free variables, it is not possible to simply 
C     call subroutine evalhess. It is necessary to copy to the end of x 
C     the values of the n - nind fixed variables (which are in the last 
C     n - nind positions of xc), rearrange vector x so it is in the 
C     full space, use subroutine evalhess and shrink both x and H (so 
C     both are in the reduced space of free variables). 
C
C     On Entry
C      
C     n        integer
C              dimension of full space
C
C     nind     integer
C              dimension of the space of free variables
C
C     ind      integer ind(nind)
C              free variables indices on original space
C
C     x        double precision x(n)
C              point in the reduced space where the Hessian 
C              evaluation is required
C
C     xc       double precision xc(n)
C              point that constains x fixes variables in its 
C              n - nind last positions
C
C     nliact   integer
C              number of linearly independent active linear
C              constraints
C     ldabar   integer
C              leading dimension of matrix Abar
C
C     Abar     double precision Abar(ldabar,nliact)
C              hold the LQ factorization of the matrix whose columns
C              correspond to the active linear constraints, after 
C              eliminating the elements correnponding to fixed variables
C
C     tau      double precision tau(nliact)
C              used to retrieve the columns of Q from Abar
C
C     macheps  double precision
C              machine epsilon
C
C     wd1,wd2,wd3 double precision wd1,wd2,wd3(n)
C              working vectors
C
C     ldh      integer
C              leading dimension of matrix H
C
C     On Return
C      
C     H        double precision H(ldh,nind-nliact)
C              reduced Hessian at x
C
C     diag     double precision diag(nind-nliact)
C              diagonal elements of H
C
C     inform   integer
C              0, if no problem occurs;
C             <0, otherwise
                
C     LOCAL SCALARS
      integer i, j

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

      call expand(nind, ind, n, x)

      call evalhess(n, x, ldh, H, inform)

      call shrink(nind, ind, n, x)
      call shrinkrow(n, nind, ind, ldh, H)
      call shrinkcol(n, nind, nind, ind, ldh, H)

      if (nliact .eq. 0) then
         go to 10
      end if

      do j = nind, 1, -1
         do i = 1, j-1
            wd3(i) = H(j,i)
         end do

         do i = j, nind
            wd3(i) = H(i,j)
         end do
         
         call multZT(nind, nliact, ldabar, Abar, tau, wd3, wd1, wd2,
     +        macheps)
         
         do i = 1, nind-nliact
            H(i,j) = wd2(i)
         end do      
      end do

      do i = 1, nind-nliact
         do j = 1, nind
            wd3(j) = H(i,j)
         end do
         
         call multZT(nind, nliact, ldabar, Abar, tau, wd3, wd1, wd2,
     +        macheps)
         
         do j = 1, nind-nliact
            H(i,j) = wd2(j)
         end do
      end do

 10   continue

      do i = 1, nind-nliact
         diag(i) = H(i,i)
      end do

      end

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

      subroutine quad(nred, x, g, ldh, H, diag, wd, phi)

C     SCALAR ARGUMENTS
      integer nred, ldh
      double precision phi
      
C     ARRAY ARGUMENTS
      double precision x(nred), g(nred), H(ldh,nred), diag(nred),
     +     wd(nred)

C     Evaluate the quadratic model phi(x) = 1/2 x^T H x + g^T x.
C
C     On Entry
C      
C     nred     integer
C              dimension of the reduced space
C
C     x        double precision x(nred)
C              point where the quadratic model is to be calculated
C
C     g        double precision g(nred)
C              vector used to define the quadratic model 
C              (see comment above)
C      
C     ldh      integer
C              leading dimension of matrix H
C
C     H        double precision H(ldh,nred)
C              symmetric lower triangular matrix used to define the 
C              quadratic model (see comment above)
C
C     diag     double precision diag(nred)
C              diagonal of matrix H
C
C     wd       double precision wd(nred)
C              working vector
C
C     On Return
C      
C     phi      double precision
C              quadratic model value at x

C     LOCAL SCALARS
      integer i, j
      
      do i = 1, nred
         wd(i) = 0.0d0
      end do
      
      do j = 1, nred
         do i = 1, j-1
            wd(i) = wd(i) + H(j,i) * x(j)
         end do
         
         wd(i) = wd(i) + diag(i) * x(j)
         
         do i = j+1, nred
            wd(i) = wd(i) + H(i,j) * x(j)
         end do
      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     ******************************************************************

      subroutine ispgls(n, nind, ind, nind2, ind2, x, f, g, l, u, ml, 
     +     mleq, lda, A, b, nact, iact, lamspg, etaint, mininterp, fmin, 
     +     maxfc, iprint, xtrial, alpha, d, gamma, sigma1, sigma2, 
     +     lossfeas, epscsn, projeps, promaxit, macheps, wi1, wd1, wd2, 
     +     lwd2, wd3, bbar, fcnt, iterql, inform)

C     SCALAR ARGUMENTS
      logical lossfeas
      integer n, nind, nind2, ml, mleq, lda, nact, mininterp, maxfc, 
     +     iprint, promaxit, lwd2, fcnt, iterql, inform
      double precision f, lamspg, etaint, fmin, alpha, gamma, sigma1, 
     +     sigma2, epscsn, projeps, macheps

C     ARRAY ARGUMENTS
      integer ind(nind), ind2(nind), iact(ml), wi1(2*n+ml)
      double precision x(n), g(nind), l(n), u(n), A(lda,n), b(ml), 
     +     xtrial(n), d(nind), wd1(n), wd2(lwd2), wd3(n), bbar(ml)
       
C     Internal Spectral Projected Gradient method.
C
C     On Entry
C
C     n        integer
C              the order of the x
C
C     nind     integer
C              dimension of reduced space
C
C     ind      integer ind(nind)
C              free variables indices on original space
C
C     nind2    integer
C              dimension of reduced space
C
C     ind2     integer ind2(nind2)
C              truely free variables indices on original space
C
C     x        double precision x(n)
C              current point
C
C     f        double precision
C              function value at the current point
C
C     g        double precision g(n)
C              gradient vector at the current point
C
C     l        double precision l(n)
C              lower bounds
C
C     u        double precision u(n)
C              upper bounds
C     
C     ml       integer
C              total number of linear constraints (excluding bounds)
C
C     mleq     integer
C              number of linear equality constraints (excluding bounds)     
C      
C     lda      integer
C              leading dimension of matrix A
C      
C     A        double precision A(lda,n)
C              coeficients of linear constraints, each row reduced to 
C              the space of truely free variables
C
C     b        double precision b(ml)
C              constant part of linear constraints
C
C     nact     integer
C              number of active linear constraints
C
C     nliact   integer
C              number of linearly independent active linear
C              constraints
C
C     iact     integer iact(ml)
C              indices of the active linear constraints. The last 
C              m - nact positions of iact store the identifier of the 
C              non-active linear constraints.
C
C     lamspg   double precision
C              spectral steplength
C
C     etaint   double precision
C              constant for the interpolation. See the description of
C              sigma1 and sigma2 above. Sometimes we take as a new 
C              trial step the previous one divided by etaint
C
C              RECOMMENDED: etaint = 2.0
C
C     mininterp integer
C              constant for testing if, after having made at least 
C              mininterp interpolations, the steplength is so small. In 
C              that case failure of the line search is declared (may be 
C              the direction is not a descent direction due to an error 
C              in the gradient calculations) 
C
C              RECOMMENDED: mininterp = 4
C     
C     fmin     double precision
C              functional value for the stopping criterion f <= fmin
C
C     maxfc    integer
C              maximum number of functional evaluations
C
C     iprint   integer
C              Commands printing. Nothing is printed if iprint is 
C              smaller than 3. 
C
C              RECOMMENDED: iprint = 2
C
C              CONSTRAINTS: allowed values are just 2 or 3.
C
C     xtrial   double precision xtrial(n)
C     d        double precision d(n)
C              working vectors
C
C     gamma    double precision
C              constant for the Armijo criterion
C              f(x + alpha d) <= f(x) + gamma * alpha * <\nabla f(x),d>
C
C              RECOMMENDED: gamma = 10^{-4}
C
C     sigma1   double precision
C     sigma2   double precision
C              constant for the safeguarded interpolation
C              if alpha_new \notin [sigma1, sigma2*alpha] then we take
C              alpha_new = alpha / etaint
C
C              RECOMMENDED: sigma1 = 0.1 and sigma2 = 0.9
C
C     lossfeas logical
C              if a loss of feasibility up to sqrt(epsfeas) is allowed
C              during the computations, lossfeas must be set to TRUE
C              (recommended). In this case, if the final iterate does
C              not satisfy the constraints with the desired precision,
C              we sugest that the user re-run the method using the final
C              point obtained as the initial point, using
C              lossfeas = FALSE
C
C     epscsn   double precision
C              feasibility tolerance for the sup-norm of the linear
C              constraints
C     
C     projeps  double precision
C              precision used in projection routine
C
C     promaxit integer
C              maximum allowed number of iterations of QL routine used 
C              in projection
C
C     macheps  double precision
C              macheps is the smallest positive number such that
C              1 + macheps is not equal to 1
C
C     wi1      integer wi1(2*n+ml)
C     wd1      double precision wd1(n)
C     wd2      double precision wd2(lwd2)
C     wd3      double precision wd3(n)
C     bbar     double precision bbar(ml)
C              working vectors
C
C     On Return
C
C     x        double precision
C              final estimation of the solution
C
C     f        double precision
C              functional value at the final estimation 
C
C     alpha    double precision
C              step lenght, such that x = x + alpha * d
C     
C     fcnt     integer
C              number of functional evaluations
C
C     iterql   integer
C              number of calls to QL routine (used in projection)
C
C     inform   integer
C              This output parameter tells what happened in this 
C              subroutine, according to the following conventions:
C
C              0 = convergence with an Armijo-like criterion
C                  (f(xnew) <= f(x) + gamma * alpha * <g,d>);
C
C              4 = the algorithm stopped because the functional value
C                  is smaller than fmin;
C
C              6 = too small step in the line search. After having made 
C                  at least mininterp interpolations, the steplength 
C                  becomes small. ''small steplength'' means that we are 
C                  at point x with direction d and step alpha, and, for 
C                  all i, 
C
C                  | alpha * d(i) | <= macheps * max (|x(i)|, 1,0d0 ). 
C 
C                  In that case failure of the line search is declared 
C                  (maybe the direction is not a descent direction due
C                  to an error in the gradient calculations). Use
C                  mininterp > maxfc to inhibit this criterion;
C
C              8 = it was achieved the maximum allowed number of
C                  function evaluations (maxfc);
C
C             10 = problem in projection subroutine. x is not modified;
C
C            -90 = means that subroutine evalf retuned an error flag.

C     LOCAL SCALARS
      logical samep
      integer i, ii, j, interp
      double precision atmp, ftrial, gtd, dsupn, xsupn, tmp

C     Print presentation information

      if (iprint .ge. 3) then
         write(*, 980) lamspg
         write(10,980) lamspg
      end if

C     Initialization

      interp = 0
      
C     Compute first trial point, spectral projected gradient direction, 
C     and directional derivative <g,d>.

      alpha = 1.0d0

      do i = 1, nind2
         xtrial(i) = x(i) - lamspg * g(i)
      end do

      do i = nind2+1, nind
         xtrial(i) = x(i)
      end do
      
C     Move all active linear constraints to the first rows of A.
C     Do the same with b.
      
      do j = 1, n
         do i = mleq+1, nact
            ii = iact(i)
            
            if (i .ne. ii) then
               tmp     = A(i,j)
               A(i,j)  = A(ii,j)
               A(ii,j) = tmp
            end if
         end do
      end do
      
      do i = mleq+1, nact
         ii = iact(i)
         
         if (i .ne. ii) then
            tmp   = b(i)
            b(i)  = b(ii)
            b(ii) = tmp
         end if
      end do
      
C     Change indices of active constraints.
      
      do i = mleq+1, nact
         iact(i) = i
      end do
      
      do i = nact+1, ml
         iact(i) = ml + nact + 1 - i
      end do
      
C     Calculate bbar = b - A_i*x_i, where x_i is a fixed variable
C     and A_i is the corresponding i-th column of A.
      
      do i = 1, ml
         bbar(i) = b(i)
      end do
      
      do j = nind2+1, n
         do i = 1, ml
            bbar(i) = bbar(i) - A(i,j) * x(j)
         end do
      end do
      
C     Project.

      call project(nind2, xtrial, l, u, ml, nact, lda, A, bbar, 
     +     promaxit, projeps, lossfeas, epscsn, tmp, macheps, wi1, wd1, 
     +     wd2, lwd2, wd3, iterql, inform)
      
      if ((inform .lt. 0) .or. (inform .eq. 2)) then
         
         inform = 10
         
         if (iprint .ge. 3) then
            write(*, 988) inform
            write(10,988) inform
         end if
         
         return
      end if
      
      gtd   = 0.0d0
      dsupn = 0.0d0
      xsupn = 0.0d0

      do i = 1, nind2
         d(i)  = xtrial(i) - x(i)
         gtd   = gtd + g(i) * d(i)
         dsupn = max(dsupn, abs(d(i)))
         xsupn = max(xsupn, abs(x(i)))
      end do

      interp = 0

 90   continue

      if (nind .ne. nind2) then
         call expand(nind2, ind2, nind, xtrial)
         call expand(nind2, ind2, nind, x)
      end if
      
      call calcobj(nind, ind, xtrial, n, x, ftrial, inform)
      
      if (nind .ne. nind2) then
         call shrink(nind2, ind2, nind, xtrial)
         call shrink(nind2, ind2, nind, x)
      end if

      fcnt = fcnt + 1
      
      if (inform .lt. 0) then

         if (iprint .ge. 3) then
            write(*, 981) alpha, ftrial, fcnt
            write(10,981) alpha, ftrial, fcnt
         end if

         if ( iprint .ge. 3 ) then
            write(*, *) '     f(x+d) is undefined.'
            write(*, *) '     Will interpolate.'
            write(10,*) '     f(x+d) is undefined.'
            write(10,*) '     Will interpolate.'
         end if

C        Compute new trial point

         interp = interp + 1
         alpha  = alpha / etaint

         do i = 1, nind2
            xtrial(i) = x(i) + alpha * d(i)
         end do
         
C        Test whether direction d is too small

         samep = .true.
         do i = 1, nind2
            if (abs(alpha * d(i)) .gt. macheps * 
     +           max(abs(x(i)),1.0d0)) then
               samep = .false.
            end if
         end do
         
         if (samep) then
            inform = 6
            
            if (iprint .ge. 3) then
               write(*, 984) inform
               write(10,984) inform
            end if
            
            go to 500
         end if

         go to 90
      end if

C     Print information of the first trial

      if (iprint .ge. 3) then
         write(*, 981) alpha, ftrial, fcnt
         write(10,981) alpha, ftrial, fcnt
      end if

C     Main loop

 100  continue

C     Test whether f is very small

      if (ftrial .le. fmin) then
         
         f = ftrial
         
         do i = 1, nind2
            x(i) = xtrial(i)
         end do

         inform = 4
         
         if (iprint .ge. 3) then
            write(*, 983) inform
            write(10,983) inform
         end if
         
         go to 500
         
      end if

C     Test Armijo stopping criterion

      if (ftrial .le. f + gamma * alpha * gtd) then

         f = ftrial
         
         do i = 1, nind2
            x(i) = xtrial(i)
         end do

         inform = 0
         
         if (iprint .ge. 3) then
            write(*, 982) inform
            write(10,982) inform
         end if
         
         go to 500
         
      end if

      if ( alpha * dsupn .le. macheps**(2.0d0/3.0d0) * xsupn .and.
     +     ftrial - f    .le. macheps**(2.0d0/3.0d0) * abs(f) ) then

         f = ftrial

         do i = 1, nind2
            x(i) = xtrial(i)
         end do
         
         inform = 0
                  
         if ( iprint .ge. 3 ) then
            write(*, 987) inform
            write(10,987) inform
         end if
         
         go to 500
         
      end if

C     Compute new step (safeguarded quadratic interpolation)

      atmp = (- gtd * alpha**2) / 
     +        (2.0d0 * (ftrial - f - alpha * gtd))
         
      if ((atmp .lt. sigma1 * alpha)
     +   .or. (atmp .gt. sigma2 * alpha)) then
         alpha = alpha / etaint
      else
         alpha = atmp
      end if

      interp = interp + 1      
      
C     Test whether direction d is too small

      samep = .true.
      do i = 1, nind2
         if (abs(alpha * d(i)) .gt. macheps * max(abs(x(i)),1.0d0)) then
            samep = .false.
         end if
      end do
      
      if ((interp .ge. mininterp) .and. samep) then
         if (ftrial .lt. f) then
            
            f = ftrial
            
            do i = 1, nind2
               x(i) = xtrial(i)
            end do
         end if
         
         inform = 6
         
         if (iprint .ge. 3) then
            write(*, 984) inform
            write(10,984) inform
         end if
         
         go to 500
      end if
           
C     Compute new trial point

      do i = 1, nind2
         xtrial(i) = x(i) + alpha * d(i)
      end do

      if (nind .ne. nind2) then
         call expand(nind2, ind2, nind, xtrial)
         call expand(nind2, ind2, nind, x)
      end if
      
      call calcobj(nind, ind, xtrial, n, x, ftrial, inform)
      
      if (nind .ne. nind2) then
         call shrink(nind2, ind2, nind, xtrial)
         call shrink(nind2, ind2, nind, x)
      end if
      
      fcnt = fcnt + 1
      
      if (inform .lt. 0) then
         if (iprint .ge. 3) then
            write(*, 986) inform
            write(10,986) inform
         end if
         
         return
      end if
      
C     Print information of the current trial

      if (iprint .ge. 3) then
         write(*, 981) alpha, ftrial, fcnt
         write(10,981) alpha, ftrial, fcnt
      end if

C     Test whether the number of functional evaluations is exhausted

      if (fcnt .ge. maxfc) then
         
         if (ftrial .lt. f) then
            
            f = ftrial
            
            do i = 1, nind2
               x(i) = xtrial(i)
            end do
            
         end if
         
         inform = 8
         
         if (iprint .ge. 3) then
            write(*, 985) inform
            write(10,985) inform
         end if

         go to 500
         
      end if
      
C     Check if the solution is feasible.
       
      do i = 1, ml
         wd2(i) = 0.0d0
      end do
      
      do j = 1, nind2
         do i = 1, ml
            wd2(i) = wd2(i) + A(i,j) * xtrial(j)
         end do
      end do
      
      if (lossfeas) then
         do i = 1, mleq
            if (abs(wd2(i) - bbar(i)) .gt. sqrt(epscsn)) then
               
               if (iprint .ge. 3) then
                  write(*, *) '     x+d is infeasible'
                  write(10,*) '     x+d is infeasible'
               end if
               
               inform = 10
               return
            end if
         end do
         
         do i = mleq+1, ml
            if (bbar(i) - wd2(i) .gt. sqrt(epscsn)) then
               
               if (iprint .ge. 3) then
                  write(*, *) '     x+d is infeasible'
                  write(10,*) '     x+d is infeasible'
               end if
               
               inform = 10
               return
            end if
         end do
      else
         do i = 1, mleq
            if (abs(wd2(i) - bbar(i)) .gt. epscsn) then
               
               if (iprint .ge. 3) then
                  write(*, *) '     x+d is infeasible'
                  write(10,*) '     x+d is infeasible'
               end if
               
               inform = 10
               return
            end if
         end do
         
         do i = mleq+1, ml
            if (bbar(i) - wd2(i) .gt. epscsn) then
               
               if (iprint .ge. 3) then
                  write(*, *) '     x+d is infeasible'
                  write(10,*) '     x+d is infeasible'
               end if
               
               inform = 10
               return
            end if
         end do
      end if
      
C     Iterate
      
      go to 100
      
C     Return
      
 500  continue

      return
      
C     Non-executable statements

 980  format(/,6x,'SPG (spectral steplength ',1PD11.4,')',/,/,
     +         6x,'SPG Line search')
 981  format(6x,'Alpha= ',1PD11.4,' F= ',1PD11.4,' FE= ',I10)
 982  format(6x,'Flag of SPG Line search = ',I3,
     +          ' (Armijo-like criterion satisfied)')
 983  format(6x,'Flag of SPG Line search = ',I3,
     +          ' (Small functional value, smaller than ',/,
     +       6X,'parameter fmin)')
 984  format(6x,'Flag of SPG Line search = ',I3,
     +          ' (Too small step in the interpolation)')
 985  format(6x,'Flag of SPG Line search = ',I3,
     +          ' (Too many functional evaluations)')
 986  format(6X,'Flag of SPG Line search = ',I3,' Fatal Error')
 987  format(6X,'Flag of SPG Line search = ',I3,
     +          '(PROVISORIO)')
 988  format(6X,'Flag of SPG Line search = ',I3,
     +      ' (Problem in projection routine)')
      end

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

      subroutine pspgls(n, x, f, g, l, u, ml, mleq, lda, A, b, nact, 
     +     iact, inorder, tolact, lamspg, etaint, mininterp, fmin, 
     +     maxfc, iprint, xtrial, alpha, gotd, d, gamma, sigma1, sigma2, 
     +     lossfeas, epscsn, projeps, promaxit, macheps, toldgp, wi1, 
     +     wd1, wd2, lwd2, wd3, wd4, fcnt, intnan, iterql, inform)

C     SCALAR ARGUMENTS
      logical inorder, gotd, lossfeas
      integer n, ml, mleq, lda, nact, tolact, mininterp, maxfc, 
     +     iprint, promaxit, lwd2, fcnt, intnan, iterql, inform
      double precision f, lamspg, etaint, fmin, alpha, gamma, sigma1, 
     +     sigma2, epscsn, projeps, macheps, toldgp

C     ARRAY ARGUMENTS
      integer iact(ml), wi1(2*n+ml)
      double precision x(n), g(n), l(n), u(n), A(lda,n), b(ml), 
     +     xtrial(n), d(n), wd1(n), wd2(lwd2), wd3(ml), wd4(n)

C     Internal Spectral Projected Gradient method.
C
C     On Entry
C
C     n        integer
C              the order of the x
C
C     x        double precision x(n)
C              current point
C
C     f        double precision
C              function value at the current point
C
C     g        double precision g(n)
C              gradient vector at the current point
C
C     l        double precision l(n)
C              lower bounds
C
C     u        double precision u(n)
C              upper bounds
C     
C     ml       integer
C              total number of linear constraints (excluding bounds)
C
C     mleq     integer
C              number of linear equality constraints (excluding bounds)     
C      
C     lda      integer
C              leading dimension of matrix A
C      
C     A        double precision A(lda,n)
C              coeficients of linear constraints
C
C     b        double precision b(ml)
C              constant part of linear constraints
C
C     nact     integer
C              number of active linear constraints
C
C     nliact   integer
C              number of linearly independent active linear
C              constraints
C
C     iact     integer iact(ml)
C              indices of the active linear constraints. The last 
C              m - nact positions of iact store the identifier of the 
C              non-active linear constraints.
C
C     inorder  logical
C              true iff constraints are already in order: equality
C              constraints in the begging, then active constraints, then
C              "nearly active" constraints and then the rest
C
C     tolact   integer
C              if inorder is true, tolact must store the position where 
C              the last "nearly active" constraint is stored, that is, 
C              tolact stores the total number of equality, active and 
C              "nearly active" constraints
C
C     lamspg   double precision
C              spectral steplength
C
C     etaint   double precision
C              constant for the interpolation. See the description of
C              sigma1 and sigma2 above. Sometimes we take as a new 
C              trial step the previous one divided by etaint
C
C              RECOMMENDED: etaint = 2.0
C
C     mininterp integer
C              constant for testing if, after having made at least 
C              mininterp interpolations, the steplength is so small. In 
C              that case failure of the line search is declared (may be 
C              the direction is not a descent direction due to an error 
C              in the gradient calculations) 
C
C              RECOMMENDED: mininterp = 4
C     
C     fmin     double precision
C              functional value for the stopping criterion f <= fmin
C
C     maxfc    integer
C              maximum number of functional evaluations
C
C     iprint   integer
C              Commands printing. Nothing is printed if iprint is 
C              smaller than 3. 
C
C              RECOMMENDED: iprint = 2
C
C              CONSTRAINTS: allowed values are just 2 or 3.
C
C     xtrial   double precision xtrial(n)
C     d        double precision d(n)
C              working vectors
C
C     gotd     logical
C              true iff direction d has already been computed
C
C     gamma    double precision
C              constant for the Armijo criterion
C              f(x + alpha d) <= f(x) + gamma * alpha * <\nabla f(x),d>
C
C              RECOMMENDED: gamma = 10^{-4}
C
C     sigma1   double precision
C     sigma2   double precision
C              constant for the safeguarded interpolation
C              if alpha_new \notin [sigma1, sigma2*alpha] then we take
C              alpha_new = alpha / etaint
C
C              RECOMMENDED: sigma1 = 0.1 and sigma2 = 0.9
C
C     lossfeas logical
C              if a loss of feasibility up to sqrt(epsfeas) is allowed
C              during the computations, lossfeas must be set to TRUE
C              (recommended). In this case, if the final iterate does
C              not satisfy the constraints with the desired precision,
C              we sugest that the user re-run the method using the final
C              point obtained as the initial point, using
C              lossfeas = FALSE
C
C     epscsn   double precision
C              feasibility tolerance for the sup-norm of the linear
C              constraints
C     
C     projeps  double precision
C              precision used in projection routine
C
C     promaxit integer
C              maximum allowed number of iterations of QL routine used 
C              in projection
C
C     macheps  double precision
C              macheps is the smallest positive number such that
C              1 + macheps is not equal to 1
C
C     toldgp   double precision
C              only linear constraints i that satisfy 
C              Ai x - bi <= toldgp*max(1,|bi|) are used in projection
C              to compute direction d
C
C     wi1      integer wi1(2*n+ml)
C     wd1      double precision wd1(n)
C     wd2      double precision wd2(lwd2)
C     wd3      double precision wd3(ml)
C     wd4      double precision wd4(n)
C              working vectors
C
C     intnan   integer
C              maximum number of times the routine should try to recover 
C              from an error occured during the objective function 
C              evaluation
C
C     On Return
C
C     x        double precision
C              final estimation of the solution
C
C     f        double precision
C              functional value at the final estimation 
C
C     alpha    double precision
C              step lenght, such that x = x + alpha * d
C     
C     fcnt     integer
C              number of functional evaluations
C
C     iterql   integer
C              number of calls to QL routine (used in projection)
C
C     inform   integer
C              This output parameter tells what happened in this 
C              subroutine, according to the following conventions:
C
C              0 = convergence with an Armijo-like criterion
C                  (f(xnew) <= f(x) + gamma * alpha * <g,d>);
C
C              4 = the algorithm stopped because the functional value
C                  is smaller than fmin;
C
C              6 = too small step in the line search. After having made 
C                  at least mininterp interpolations, the steplength 
C                  becomes small. ''small steplength'' means that we are 
C                  at point x with direction d and step alpha, and, for 
C                  all i, 
C
C                  | alpha * d(i) | <= macheps * max (|x(i)|, 1,0d0 ). 
C 
C                  In that case failure of the line search is declared 
C                  (maybe the direction is not a descent direction due
C                  to an error in the gradient calculations). Use
C                  mininterp > maxfc to inhibit this criterion;
C
C              8 = it was achieved the maximum allowed number of
C                  function evaluations (maxfc);
C
C             10 = problem in projection subroutine. x is not modified;
C
C            -90 = means that subroutine evalf retuned an error flag.

C     LOCAL SCALARS
      logical samep
      integer i, ii, j, interp
      double precision atmp, ftrial, gtd, dsupn, xsupn, tmp, maxstp, ax, 
     +     ad

C     Print presentation information

      if (iprint .ge. 3) then
         write(*, 980) lamspg
         write(10,980) lamspg
      end if

C     Initialization

      interp = 0
      
C     If direction d has already been calculated, skip first part.


      if (gotd) then
         go to 10
      end if

C     Compute spectral discontinuous projected gradient direction.

      do i = 1, n
         d(i) = x(i) - lamspg * g(i)
      end do

      if (.not. inorder) then

C        Move all active linear constraints to the first rows of A.
C        Do the same with b. 
      
         do j = 1, n
            do i = mleq+1, nact
               ii = iact(i)
               
               if (i .ne. ii) then
                  tmp     = A(i,j)
                  A(i,j)  = A(ii,j)
                  A(ii,j) = tmp
               end if
            end do
         end do
         
         do i = mleq+1, nact
            ii = iact(i)
            
            if (i .ne. ii) then
               tmp   = b(i)
               b(i)  = b(ii)
               b(ii) = tmp
            end if
         end do
      
C        Change indices of active constraints.
      
         do i = mleq+1, nact
            iact(i) = i
         end do
         
         do i = nact+1, ml
            iact(i) = ml + nact + 1 - i
         end do
      
C        Move all "almost" active linear constraints to the first rows 
C        of A. Do the same with b.
      
         tolact = nact
         
         do i = nact+1, ml
            wd3(i) = 0.0d0
         end do
         
         do j = 1, n
            do i = nact+1, ml
               wd3(i) = wd3(i) + A(i,j) * x(j)
            end do
         end do
         
         do i = nact+1, ml
            ax = wd3(i)
            
            if (ax - b(i) .le. toldgp*max(1.0d0,abs(b(i)))) then
               
               tolact = tolact + 1
               ii     = tolact
               
               if (i .ne. ii) then
                  do j = 1, n
                     tmp     = A(i,j)
                     A(i,j)  = A(ii,j)
                     A(ii,j) = tmp
                  end do
                  
                  tmp   = b(i)
                  b(i)  = b(ii)
                  b(ii) = tmp
                  
                  tmp     = wd3(i)
                  wd3(i)  = wd3(ii)
                  wd3(ii) = tmp
               end if
            end if
         end do
      end if

C     Use only active constraits to project

      call project(n, d, l, u, tolact, mleq, lda, A, b, promaxit, 
     +     projeps, lossfeas, epscsn, tmp, macheps, wi1, wd1, wd2, lwd2,
     +     wd4, iterql, inform)

      if ((inform .lt. 0) .or. (inform .eq. 2)) then
         
         inform = 10
         
         if (iprint .ge. 3) then
            write(*, 988) inform
            write(10,988) inform
         end if
         
         return
      end if

      do i = 1, n
         d(i) = d(i) - x(i)
      end do

C     Compute maximum step.
      
      do i = tolact+1, ml
         wd2(i) = 0.0d0
      end do
      
      do j = 1, n
         do i = tolact+1, ml
            wd2(i) = wd2(i) + A(i,j) * d(j)
         end do
      end do
      
      maxstp = 1.0d0
      
      do i = tolact+1, ml
         ad = wd2(i)
         ax = wd3(i)
         
         if (ad .lt. 0.0d0) then
            maxstp = min(maxstp, (b(i) - ax) / ad)
         end if
      end do

      do i = 1, n
         d(i) = maxstp * d(i)
      end do

      if (maxstp .le. 0.1d0) then
         if (toldgp .lt. 1.0d+99) then
            toldgp = toldgp*1.0d2
         end if
      end if

C     Compute first point xtrial, g^td and norms of x and d.

 10   continue

      alpha = 1.0d0
      gtd   = 0.0d0
      dsupn = 0.0d0
      xsupn = 0.0d0

      do i = 1, n
         xtrial(i) = x(i) + d(i)
         gtd   = gtd + g(i) * d(i)
         dsupn = max(dsupn, abs(d(i)))
         xsupn = max(xsupn, abs(x(i)))
      end do

      interp = 0

 90   continue

      call evalobj(n, xtrial, ftrial, inform)
      fcnt = fcnt + 1
      
      if (inform .lt. 0) then

         if (iprint .ge. 3) then
            write(*, 981) alpha, ftrial, fcnt
            write(10,981) alpha, ftrial, fcnt
         end if

         if ( intnan .gt. 100 ) then

            if ( iprint .ge. 3 ) then
               write(*, *) '     f(x+d) is undefined. PSPG will stop.'
               write(10,*) '     f(x+d) is undefined. PSPG will stop.'
            end if

            return
         end if

         if ( interp .gt. 4 ) then

            if ( iprint .ge. 3 ) then
               write(*, *) '     f(x+d) is undefined after 4'
               write(*, *) '     interpolations. PSPG will stop.'
               write(10,*) '     f(x+d) is undefined after 4'
               write(10,*) '     interpolations. PSPG will stop.'
            end if

            intnan = intnan + 1

            return
         end if

         if ( iprint .ge. 3 ) then
            write(*, *) '     f(x+d) is undefined.'
            write(*, *) '     Will interpolate.'
            write(10,*) '     f(x+d) is undefined.'
            write(10,*) '     Will interpolate.'
         end if

C        Compute new trial point

         interp = interp + 1
         alpha  = alpha / etaint

         do i = 1, n
            xtrial(i) = x(i) + alpha * d(i)
         end do
         
C        Test whether direction d is too small

         samep = .true.
         do i = 1, n
            if (abs(alpha * d(i)) .gt. macheps * 
     +           max(abs(x(i)),1.0d0)) then
               samep = .false.
            end if
         end do
         
         if (samep) then
            inform = 6
            
            if (iprint .ge. 3) then
               write(*, 984) inform
               write(10,984) inform
            end if
            
            go to 500
         end if

         go to 90
      end if

      if (interp .gt. 0) then
         intnan = intnan + 1
      end if

C     Print information of the first trial

      if (iprint .ge. 3) then
         write(*, 981) alpha, ftrial, fcnt
         write(10,981) alpha, ftrial, fcnt
      end if

C     Main loop

 100  continue

C     Test whether f is very small

      if (ftrial .le. fmin) then
         
         f = ftrial
         
         do i = 1, n
            x(i) = xtrial(i)
         end do

         inform = 4
         
         if (iprint .ge. 3) then
            write(*, 983) inform
            write(10,983) inform
         end if
         
         go to 500
         
      end if

C     Test Armijo stopping criterion

      if (ftrial .le. f + gamma * alpha * gtd) then

         f = ftrial
         
         do i = 1, n
            x(i) = xtrial(i)
         end do
         
         inform = 0
         
         if (iprint .ge. 3) then
            write(*, 982) inform
            write(10,982) inform
         end if
         
         go to 500
         
      end if

      if ( alpha * dsupn .le. macheps**(2.0d0/3.0d0) * xsupn .and.
     +     ftrial - f    .le. macheps**(2.0d0/3.0d0) * abs(f) ) then

         f = ftrial
         
         do i = 1,n
            x(i) = xtrial(i)
         end do
                  
         inform = 0
                  
         if ( iprint .ge. 3 ) then
            write(*, 987) inform
            write(10,987) inform
         end if
         
         go to 500
         
      end if

C     Compute new step (safeguarded quadratic interpolation)

      atmp = (- gtd * alpha**2) / 
     +        (2.0d0 * (ftrial - f - alpha * gtd))
         
      if ((atmp .lt. sigma1 * alpha) .or. 
     +    (atmp .gt. sigma2 * alpha)) then
         alpha = alpha / etaint
      else
         alpha = atmp
      end if

      interp = interp + 1      
      
C     Test whether direction d is too small

      samep = .true.
      do i = 1, n
         if (abs(alpha * d(i)) .gt. macheps * max(abs(x(i)),1.0d0)) then
            samep = .false.
         end if
      end do
      
      if ((interp .ge. mininterp) .and. samep) then
         if (ftrial .lt. f) then
            
            f = ftrial
            
            do i = 1, n
               x(i) = xtrial(i)
            end do
         end if
         
         inform = 6
         
         if (iprint .ge. 3) then
            write(*, 984) inform
            write(10,984) inform
         end if
         
         go to 500
      end if
           
C     Compute new trial point

      do i = 1, n
         xtrial(i) = x(i) + alpha * d(i)
      end do

      call evalobj(n, xtrial, ftrial, inform)
      fcnt = fcnt + 1
      
      if (inform .lt. 0) then
         if (iprint .ge. 3) then
            write(*, 986) inform
            write(10,986) inform
         end if
         
         return
      end if
      
C     Print information of the current trial

      if (iprint .ge. 3) then
         write(*, 981) alpha, ftrial, fcnt
         write(10,981) alpha, ftrial, fcnt
      end if

C     Test whether the number of functional evaluations is exhausted

      if (fcnt .ge. maxfc) then
         
         if (ftrial .lt. f) then
            
            f = ftrial
            
            do i = 1, n
               x(i) = xtrial(i)
            end do
            
         end if
         
         inform = 8
         
         if (iprint .ge. 3) then
            write(*, 985) inform
            write(10,985) inform
         end if

         go to 500
         
      end if
      
C     Check if the solution is feasible.
       
      do i = 1, ml
         wd2(i) = 0.0d0
      end do
      
      do j = 1, n
         do i = 1, ml
            wd2(i) = wd2(i) + A(i,j) * xtrial(j)
         end do
      end do
      
      if (lossfeas) then
         do i = 1, mleq
            if (abs(wd2(i) - b(i)) .gt. sqrt(epscsn)) then
               
               if (iprint .ge. 3) then
                  write(*, *) '     x+d is infeasible'
                  write(10,*) '     x+d is infeasible'
               end if
               
               inform = 10
               return
            end if
         end do
         
         do i = mleq+1, ml
            if (b(i) - wd2(i) .gt. sqrt(epscsn)) then
               
               if (iprint .ge. 3) then
                  write(*, *) '     x+d is infeasible'
                  write(10,*) '     x+d is infeasible'
               end if
               
               inform = 10
               return
            end if
         end do
      else
         do i = 1, mleq
            if (abs(wd2(i) - b(i)) .gt. epscsn) then
               
               if (iprint .ge. 3) then
                  write(*, *) '     x+d is infeasible'
                  write(10,*) '     x+d is infeasible'
               end if
               
               inform = 10
               return
            end if
         end do
         
         do i = mleq+1, ml
            if (b(i) - wd2(i) .gt. epscsn) then
               
               if (iprint .ge. 3) then
                  write(*, *) '     x+d is infeasible'
                  write(10,*) '     x+d is infeasible'
               end if
               
               inform = 10
               return
            end if
         end do
      end if

C     Iterate
      
      go to 100
      
C     Return
      
 500  continue

      return
      
C     Non-executable statements

 980  format(/,6x,'PSPG (spectral steplength ',1PD11.4,')',/,/,
     +         6x,'PSPG Line search')
 981  format(6x,'Alpha= ',1PD11.4,' F= ',1PD11.4,' FE= ',I10)
 982  format(6x,'Flag of PSPG Line search = ',I3,
     +          ' (Armijo-like criterion satisfied)')
 983  format(6x,'Flag of PSPG Line search = ',I3,
     +          ' (Small functional value, smaller than ',/,
     +       6X,'parameter fmin)')
 984  format(6x,'Flag of PSPG Line search = ',I3,
     +          ' (Too small step in the interpolation)')
 985  format(6x,'Flag of PSPG Line search = ',I3,
     +          ' (Too many functional evaluations)')
 986  format(6X,'Flag of PSPG Line search = ',I3,' Fatal Error')
 987  format(6X,'Flag of PSPG Line search = ',I3,
     +          '(PROVISORIO)')
 988  format(6X,'Flag of PSPG Line search = ',I3,
     +      ' (Problem in projection routine)')
      end

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

      subroutine dogleg(n, g, ldh, H, diag, pd, delta, macheps, pu, p, 
     +     inform)
      
C     SCALAR ARGUMENTS
      logical pd
      integer n, ldh, inform
      double precision delta, macheps
      
C     ARRAY ARGUMENTS
      double precision g(n), H(ldh,n), diag(n), pu(n), 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     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     ldh      integer
C              leading dimension of matrix H
C
C     H        double precision H(ldh,n)
C              symmetric n x n matrix used to define the quadratic 
C              function. Just the lower triangular portion must be 
C              defined. Both the upper triangular portion and the 
C              diagonal will be modified to store the Cholesky 
C              decomposition of (B + lI) = R^TR
C
C     diag     double precision diag(n)
C              diagonal of matrix H
C
C     pd       logical
C              indicates if the last Cholesky decomposition of MEQB was
C              successfull. That is, if the last matrix used by MEQB was
C              positive definite
C     
C     delta    double precision
C              trust-region radius
C     
C     macheps  double precision
C              machine epsilon
C
C     pu       double precision pu(n)
C              working array
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     inform   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     LOCAL SCALARS
      integer i, j
      double precision pueucn, pueucn2, pbeucn2, geucn, geucn2, gthg,
     +     coef, putpb, a, b, c, d, r, delta2

      inform = 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 999
      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 j = 1, n
         pu(j) = pu(j) + diag(j) * g(j)
         
         do i = j+1, n
            pu(i) = pu(i) + H(i,j) * g(j)
         end do
      end do
      
      gthg = 0.0d0
      do i = 1, n
         gthg = gthg + pu(i)**2
      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 999
      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. macheps**(2.0d0/3.0d0)) .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 999

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 j = 1, n
         pu(j) = pu(j) + diag(j) * g(j)
         
         do i = j+1, n
            pu(i) = pu(i) + H(i,j) * g(j)
         end do
      end do
      
      gthg = 0.0d0
      do i = 1, n
         gthg = gthg + pu(i)**2
      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. macheps**(2.0d0/3.0d0)) .and. 
     +     (geucn .le. macheps**(2.0d0/3.0d0))) then
         inform = 0
         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

 999  end
      
C     ******************************************************************
C     ******************************************************************

      subroutine MEQB(n, g, ldb, B, diag, delta, sigma1, sigma2, eps, 
     +     macheps, maxit, iprint, t, z, wd1, l, pd, p, chcnt, inform)

C     SCALAR ARGUMENTS
      logical pd
      integer n, ldb, maxit, iprint, chcnt, inform
      double precision delta, sigma1, sigma2, eps, macheps, l

C     ARRAY ARGUMENTS
      double precision g(n), B(ldb,n), diag(n), t(n), z(n), wd1(n), p(n)
      
C     Method to minimize quadratic functions subjected to ||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     ldb      integer
C              leading dimension of matrix B
C
C     B        double precision B(ldb,n)
C              symmetric n x n matrix used to define the quadratic 
C              function. Just the lower triangular portion must be 
C              defined. Both the upper triangular portion and the 
C              diagonal will be modified to store the Cholesky 
C              decomposition of (B + lI) = R^TR
C
C     diag     double precision diag(n)
C              diagonal of matrix B
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     macheps  double precision
C              machine epsilon
C
C     maxit    integer
C              maximum number of allowed iterations
C     
C     iprint   integer
C              data printing options:
C
C             -1 = nothing is printed;
C      
C              0 = just the data from final iteration is printed;
C      
C             >0 = data obtained at each iprint iterations is printed
C
C     t        double precision t(n)
C     z        double precision z(n)
C     wd1      double precision wd1(n)
C              working vectors
C
C     l        double precision
C              initial value for mslamb
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     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     chcnt    integer
C              number of Cholesky decompositions
C
C     inform   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     LOCAL SCALARS
      integer i, j, idx, iter
      double precision ll, lu, ls, teucn2, peunc, peunc2, geucn, b1n,
     +     tmp, d, ueucn2, rpeucn2, rzeucn2, tau, ptz, delta2, sgn, 
     +     luant, llant, lsant 

      delta2 = delta**2
      inform = -1

C     step 1: initialize ls (lower bound on l) with max{-bii}, where bii 
C             are the elements of the diagonal of B

      ls = -diag(1)
      do i = 2, n
         if (-diag(i) .gt. ls) then
            ls = -diag(i)
         end if
      end do
      
C     Calculate ||B||1, B dense
      
      b1n = 0.0d0
      do j = 1, n
         tmp = 0.0d0
         do i = 1, j-1
            tmp = tmp + abs(B(j,i))
         end do
         
         tmp = tmp + abs(diag(i))
         
         do i = j+1, n
            tmp = tmp + abs(B(i,j))
         end do
         
         if (tmp .gt. b1n) then
            b1n = tmp
         end if
      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 = dsqrt(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. macheps**(2.0d0/3.0d0)) .and.
     +     (abs(lu) .le. macheps**(2.0d0/3.0d0)) .and. 
     +     (abs(ls) .le. macheps**(2.0d0/3.0d0))) then
         inform = 0
         go to 21
      end if

C     step 4: initialize iteration counter

      iter = 1

C     step 5: safeguard of l (ensures that l is bigger than ll)
      
 5    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 + macheps**(2.0d0/3.0d0)*max(abs(ls),1.0d0)) .and.
     +     (iter .ne. 1)) then
         l = max(1.0d-3 * lu, dsqrt(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)

      call cholesky(n, ldb, B, l, diag, macheps, d, idx, pd)
      chcnt = chcnt + 1

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 (iprint .ge. 3) then
            write(*, 980) iter
            write(*, 981) ls, ll, lu, l
            write(*, 988)
 
            write(10,980) iter
            write(10,981) ls, ll, lu, l
            write(10,988) 
         end if

         llant = ll
         luant = lu
         lsant = ls
         
         if (lu-l .le. 
     +        macheps**(2.0d0/3.0d0)*max(abs(lu),1.0d0)) then
            lu = lu + macheps**(2.0d0/3.0d0)*max(abs(lu),1.0d0)
            l = lu
         else
            call calcu(idx, ldb, B, p, ueucn2)
            
            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
            inform = 5
            
            if (iprint .ge. 3) then
               write(*, 989) inform, maxit
               write(10,989) inform, maxit
            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

      call solvesys(n, ldb, B, g, 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
      
      peunc2 = 0.0d0
      do i = 1, n
         peunc2 = peunc2 + p(i)**2
      end do
      peunc = dsqrt(peunc2)
      
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 (peunc .lt. delta) then

C        Calculate z

         call calcz(n, ldb, B, macheps, z)
                  
C        Calculate z Euclidian-norm

         tmp = 0.0d0
         do i = 1, n
            tmp = tmp + z(i)**2
         end do
         tmp = dsqrt(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
            wd1(i) = 0.0d0
         end do
         
         do j = 1, n
            do i = 1, j
               wd1(i) = wd1(i) + B(i,j) * z(j)
            end do
         end do
         
         rzeucn2 = 0.0d0
         do i = 1, n
            rzeucn2 = rzeucn2 + wd1(i)**2
         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 - peunc2

         tau = (ptz**2) + tmp
         tau = tmp / (ptz + sgn * sqrt(tau))         
 
      end if

C     Print informations (current iteration)

      if (iprint .ge. 3) then
         write(*, 980) iter
         write(*, 981) ls, ll, lu, l
         write(*, 982) peunc

         write(10,980) iter
         write(10,981) ls, ll, lu, l
         write(10,982) peunc

         if (peunc .lt. delta) then
            write(*, 983) sqrt(peunc2 + 2 * tau * ptz + tau ** 2)
            write(10,983) sqrt(peunc2 + 2 * tau * ptz + tau ** 2)
         else
            write(*, 983) peunc
            write(10,983) peunc
         end if

         write(*, 985) delta
         write(10,985) delta
      end if

C     steps 11 and 12: update ll, lu and ls

      llant = ll
      luant = lu
      lsant = ls

      if (peunc .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. (peunc .le. delta)) then
         inform = 1
         go to 21
      end if

C     step 16: second convergence test

      if (abs(delta - peunc) .le. sigma1*delta) then
         inform = 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 ((peunc .lt. delta) .and. ((rzeucn2*(tau**2) .le. tmp) 
     +     .or. (lu - ll .le. eps))) then
         inform = inform + 3
         go to 20
      end if

      if (inform .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 + macheps**(2.0d0/3.0d0)*max(abs(ll),1.0d0))
     +     .and. (ls .le. ll))) then 

C        Solve R^Tt = p for t and calculate t squared Euclidian-norm
         
         do i = 1, n
            t(i) = p(i)
         end do
            
         do j = 1, n           
            do i = 1, j-1
               t(j) = t(j) - B(i,j) * t(i)
            end do
            t(j) = t(j) / B(j,j)
         end do
         
         teucn2 = 0.0d0
         do i = 1, n
            teucn2 = teucn2 + t(i)**2
         end do
               
C        Update l using Newton's method update
         
         l = l + (peunc2 / teucn2) * ((peunc - 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
         inform = 5
         
         if (iprint .ge. 3) then
            write(*, 989) inform, maxit
            write(10,989) inform, maxit
         end if
         
         go to 22
      end if      
            
C     step 23: start a new iteration

      if ((abs(llant-ll) .le. 
     +                  macheps**(2.0d0/3.0d0)*max(abs(ll),1.0d0)) .and. 
     +     (abs(luant-lu) .le.
     +                  macheps**(2.0d0/3.0d0)*max(abs(lu),1.0d0)) .and. 
     +     (abs(lsant-ls) .le. 
     +                  macheps**(2.0d0/3.0d0)*max(abs(ls),1.0d0))) then
         
         ll = ll + macheps**(2.0d0/3.0d0)*max(abs(ll),1.0d0)
         lu = lu - macheps**(2.0d0/3.0d0)*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 - peunc2)

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 - peunc2)

 20   tmp = (rzeucn2 * (tau**2)) - l * (delta2 - peunc2)

      if ((inform .eq. 3) .or. 
     +     ((inform .eq. 5) .and. (tmp .le. 0.0d0))) then
         
         peunc2 = 0.0d0
         do i = 1, n
            p(i) = p(i) + tau * z(i)
            peunc2 = peunc2 + p(i)**2
         end do
         peunc = dsqrt(peunc2)

         inform = 3
      else
         inform = 2
      end if

C     Print informations

 21   if (iprint .ge. 3) then
         write(*, 986) iter
         write(*, 981) ls, ll, lu, l
         write(*, 987) inform
         write(*, 984) peunc

         write(10,986) iter
         write(10,981) ls, ll, lu, l
         write(10,987) inform
         write(10,984) peunc
      end if
      
 22   continue
      
C     Non-executable statements

 980  format(/6X,'MEQB iteration: ',I6)
 981  format(6X,'ls = ',1PD11.4,
     +       6X,'ll = ',1PD11.4,
     +       6X,'lu = ',1PD11.4,
     +       6X,'l  = ',1PD11.4)
 982  format(6X,'Euclidian-norm of p: ',1PD11.4)
 983  format(6X,'Euclidian-norm of p + z: ',1PD11.4)
 984  format(6X,'Euclidian-norm of s (solution): ',1PD11.4)
 985  format(6X,'delta: ',1PD11.4)
 986  format(6X,'Number of iterations: ',I7)
 987  format(6X, 'Flag of MEQB = ',I3,
     +       6X,' (convergence criterion satisfied)',/)
 988  format(6X,'B + lI is not positive definite!')
 989  format(6X,'Flag of MEQB = ',I3,
     +     ' (It exceeded the maximum allowed number of iterations',
     +       6X,'(maxit=',I7,')',/)
      end

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

      subroutine cholesky(n, ldb, B, l, diag, macheps, d, idx, pd)

C     SCALAR ARGUMENTS
      logical pd
      integer n, ldb, idx
      double precision macheps, l, d
      
C     ARRAY ARGUMENTS
      double precision B(ldb,n), diag(n)
      
C     Cholesky decomposition.
C     If B + lI is a symmetric positive definite n x n matrix, B will 
C     store R, where R is such that B + lI = R^TR and pd is set to true.
C     Because R is upper triangular, just this portion of B will be 
C     changed. (remember the original diagonal of B is stored at diag).
C     If B + lI is not positive definite, pd is set to false and both d 
C     and idx can be set (look the definition of the latter two below).
C
C     On Entry
C      
C     n        integer
C              dimension
C
C     ldb      integer
C              leading dimension of matrix B
C
C     B        double precision B(ldb,n)
C              symmetric n x n matrix (just the lower triangular portion 
C              must be defined)
C
C     l        double precision
C              used to calculate B + lI
C
C     diag     double precision diag(n)
C              diagonal of matrix B
C
C     macheps  double precision
C              machine epsilon
C      
C     On Return
C     
C     B        double precision B(ldb,n)
C              Cholesky decomposition of B + lI, when it is possible
C              to calculate, stored in the upper triangular part of  
C              B (including the diagonal)
C
C     idx      integer
C              when B + lI is not positive definite, idx is the index 
C              where the decomposition fails
C
C     d        double precision
C              when B + lI is not positive definite, the submatrix S 
C              of (B + lI) with indices from 1 to idx and with d added  
C              to the element in (idx,idx), is a singular matrix
C
C     pd       logical
C              true iff B + lI is positive definite

C     LOCAL SCALARS
      integer i, j, k
      double precision sum

      pd = .true.
      
      do j = 1, n
         
         sum = diag(j) + l
         
         do k = j - 1, 1, -1
            sum = sum - B(k,j)**2
         end do
         
         if (sum .le. -macheps**(2.0d0/3.0d0)) then
            d = - sum
            idx = j
            pd  = .false.
            return
         else if (abs(sum) .le. macheps**(2.0d0/3.0d0)) then
            d   = macheps**(2.0d0/3.0d0)
            idx = j
            pd  = .false.
            return
         else 
            B(j,j) = dsqrt(sum)
         end if
               
         do i = j+1, n
            sum = B(i,j)
            
            do k = j - 1, 1, -1
               sum = sum - B(k,j) * B(k,i)
            end do
                        
            B(j,i) = sum / B(j,j)
         end do
 
      end do     

      end

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

      subroutine solvesys(n, lda, A, b, x)

C     SCALAR ARGUMENTS
      integer n, lda
      
C     ARRAY ARGUMENTS
      double precision A(lda,n), b(n), x(n)

C     Solve system Ax = -b, where A is the Cholesky decomposition of a 
C     matrix B + lI. Just the upper triangular portion of A will be used
C     (as well as its diagonal).
C
C     On Entry
C
C     n        integer
C              dimension
C
C     lda      integer
C              leading dimension of matrix A
C
C     A        double precision A(lda,n)
C              matrix n x n, containing R in its upper triangular
C              portion
C     
C     b        double precision b(n)
C              negative of right hand side
C
C     On Return
C     
C     x        double precision x(n)
C              system solution
                         
C     LOCAL SCALARS
      integer i, j

      do i = 1, n
         x(i) = -b(i)
      end do
      
      do j = 1, n           
         do i = 1, j-1
            x(j) = x(j) - A(i,j) * x(i)
         end do
         x(j) = x(j) / A(j,j)
      end do
      
      do j = n, 1, -1
         x(j) = x(j) / A(j,j)
         do i = 1, j-1
            x(i) = x(i) - A(i,j) * x(j)
         end do
      end do

      end

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

      subroutine calcu(k, lda, A, u, ueucn2)

C     SCALAR ARGUMENTS
      integer k, lda
      double precision ueucn2
      
C     ARRAY ARGUMENTS
      double precision A(lda,k), u(k)

C     Solve a linear system of the form (A + ekek^Td)u = 0, where A is, 
C     in fact, the Cholesky decomposition of B + lI until entry k-1 in
C     its upper portion (row number >= column number). 
C     u is a vector of k positions with u(k) = 1.
C
C     On Entry
C      
C     k        integer
C              dimension of e
C
C     lda      integer
C              leading dimension if matrix A
C
C     A        double precision A(lda,k)
C              upper triangular matrix
C
C     On Return
C      
C     u        double precision u(k)
C              system solution
C
C     ueucn2   double precision
C              u squared Euclidian-norm

C     LOCAL SCALARS
      integer i, j

      do i = 1, k-1
         u(i) = -A(k,i)
      end do
      
      do j = 1, k-1           
         do i = 1, j-1
            u(j) = u(j) - A(i,j) * u(i)
         end do
         u(j) = u(j) / A(j,j)
      end do

      do j = k-1, 1, -1
         u(j) = u(j) / A(j,j)
         do i = 1, j-1
            u(i) = u(i) - A(i,j) * u(j)
         end do
      end do

      u(k) = 1.0d0

      ueucn2 = 0.0d0
      do i = 1, k
         ueucn2 = ueucn2 + u(i)**2
      end do

      end      

C     ******************************************************************
C     ******************************************************************      
      
      subroutine calcz(n, ldr, R, macheps, z)

C     SCALAR ARGUMENTS
      integer ldr, n
      double precision macheps
      
C     ARRAY ARGUMENTS
      double precision R(ldr,n), z(n)

C     Implementation of the technique presented by Cline, Moler, Stewart 
C     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
C     On Entry
C
C     n        integer      
C              dimension of R
C      
C     ldr      integer
C              leading dimension of R
C
C     R        double precision R(ldr,n)
C              upper triangular matrix (Cholesky decomposition of
C              B + lI)
C
C     On Return
C      
C     z        double precision z(n)
C              approximation of the eigenvector of B associated to
C              \mslamb_1

C     LOCAL SCALARS
      integer i, k
      double precision w, wk, wkm, ek, s, sm, rkk, rki
      
      ek = 1.0d0
      
      do i = 1, n
         z(i) = 0.0d0
      end do
      
      do k = 1, n
         if (abs(z(k)) .gt. macheps**(2.0d0/3.0d0)) then
            ek = dsign(ek,-z(k))
         end if

         rkk = R(k,k)
         
         if (abs(ek-z(k)) .gt. abs(rkk)) then
            s = abs(rkk) / abs(ek-z(k))            
            do i = 1, n
               z(i) = s * z(i)
            end do
            ek = s * ek
         end if

         wk = ek - z(k)
         wkm = -ek - z(k)
         s = abs(wk)
         sm = abs(wkm)
         
         if (rkk .eq. 0.0d0) then 
            wk = 1.0d0
            wkm = 1.0d0
         else
            wk = wk / rkk
            wkm = wkm / rkk
         end if

         if (k .eq. n) then
            go to 10
         end if
         
         do i = k+1, n
            rki  = R(k,i)
            sm   = sm + abs(z(i) + wkm * rki)
            z(i) = z(i) + wk * rki
            s    = s + abs(z(i))
         end do

         if (s .lt. sm - macheps**(2.0d0/3.0d0)*max(abs(sm),1.0d0)) then
            w  = wkm - wk
            wk = wkm
            
            do i = k+1, n
               rki  = R(k,i)
               z(i) = z(i) + w * rki
            end do
         end if

 10      z(k) = wk
      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
      
      do k = n, 1, -1
         z(k) = z(k) / R(k,k)                  
         do i = 1, k-1
            z(i) = z(i) - R(i,k) * z(k)
         end do
      end do
      
      end

C     ******************************************************************
C     ******************************************************************
 
      subroutine multQT(n, t, lda, A, tau, w, qw, macheps)

C     SCALAR ARGUMENTS                   
      integer n, t, lda
      double precision macheps

C     ARRAY ARGUMENTS
      double precision A(lda,t), tau(t), w(n), qw(n)

C     This routine multiplies vector w by matrix Q (from QR factorization
C     of matrix A). 
C     The matrix Q is represented as a product of elementary reflectors
C     Q = H(1) H(2) . . . H(k), where k = min(m,n).
C     Each H(i) has the form H(i) = I - tau * v * v'
C     where tau is a real scalar, and v is a real vector with
C     v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored in A(i+1:m,i), and
C     tau in TAU(i).
C
C     On Entry
C
C     n        integer
C              number of rows of A
C
C     m        integer
C              number of columns of A
C
C     lda      integer
C              leading dimension of A
C
C     A        double precision A(lda,m)
C              matrix factorized by DGEQP3 routine. v(i+1:m) is
C              stored in A(i+1:m,i) (see comment above)
C
C     tau      double precision tau(m)
C              coeficient used to calculate reflectors (returned
C              by DGEQP3 routine)
C
C     w        double precision w(n)
C              vector to be multiplied by Z
C
C     macheps  double precision
C              machine epsilon
C
C     On return
C
C     qw       double precision qw(n)
C              result of vector w multiplied by Q. qw = Q w.      

C     LOCAL SCALARS
      integer i, j
      double precision gama

      do i = 1, n
         qw(i) = w(i)
      end do
    
      do j = 1, t

C        Calculate gama = v(j:n)^T qw(j:n).
         
         gama = qw(j)
         do i = j+1, n
            gama = gama + A(i,j) * qw(i)
         end do
         
C        Calculate qw(j:n) = qw(j:n) - tau(j) gama v(j:n)
C                          = qw(j:n) - tau(j) v(j:n)^T qw(j:n) v(j:n).

         if ((abs(gama) .gt. macheps) .and.
     +        (abs(tau(j)) .gt. macheps)) then
 
            qw(j) = qw(j) - tau(j) * gama
            do i = j+1, n
               qw(i) = qw(i) - tau(j) * gama * A(i,j)
            end do
         end if
      end do

      end
      
C     ******************************************************************
C     ******************************************************************
 
      subroutine multZ(n, t, lda, A, tau, w, zw, macheps)

C     SCALAR ARGUMENTS      
      integer n, t, lda
      double precision macheps
      
C     ARRAY ARGUMENTS
      double precision A(lda,t), tau(t), w(n-t), zw(n)

C     This routine multiplies vector w by matrix Z. Z is the matrix
C     formed by the last n-t columns of matrix Q (from QR factorization
C     of matrix A). 
C     The matrix Q is represented as a product of elementary reflectors
C     Q = H(1) H(2) . . . H(t), where t <= min(m,n).
C     Each H(i) has the form H(i) = I - tau * v * v'
C     where tau is a real scalar, and v is a real vector with
C     v(1:i-1) = 0 and v(i) = 1; v(i+1:t) is stored in A(i+1:t,i), and
C     tau in TAU(i).
C
C     On Entry
C
C     n        integer
C              number of rows of A
C
C     t        integer
C              n-t is the number of columns of Z
C
C     lda      integer
C              leading dimension of A
C
C     A        double precision A(lda,t)
C              matrix factorized by DGEQP3 routine. v(i+1:t) is
C              stored in A(i+1:t,i) (see comment above)
C
C     tau      double precision tau(t)
C              coeficient used to calculate reflectors (returned
C              by DGEQP3 routine)
C
C     w        double precision w(n-t)
C              vector to be multiplied by Z
C
C     macheps  double precision
C              machine epsilon
C
C     On return
C
C     zw       double precision zw(n)
C              result of vector w multiplied by Z. zw = Z w.      

C     LOCAL SCALARS
      integer i, j
      double precision gama

C     If t = 0 then Z = I
      
      if (t .eq. 0) then
         do i = 1, n
            zw(i) = w(i)
         end do
         return
      end if
      
C     Multiplies vector w by last n-t columns of Hm
      
      gama = 0.0d0
      do i = n, t+1, -1
         gama = gama + A(i,t) * w(i-t)
      end do
      
      do i = 1, t
         zw(i) = 0.0d0
      end do

      do i = 1, n-t
         zw(t+i) = w(i)
      end do

      if ((abs(gama) .gt. macheps) .and.
     +     (abs(tau(t)) .gt. macheps)) then
         
         zw(t) = zw(t) - tau(t) * gama
         do i = t+1, n
            zw(i) = zw(i) - tau(t) * gama * A(i,t)
         end do
      end if
      
      do j = t-1, 1, -1

C        Calculate gama = v(j:n)^T zw(j:n).

         gama = zw(j)
         do i = j+1, n
            gama = gama + A(i,j) * zw(i)
         end do
         
C        Calculate wd(j:n) = zw(j:n) - tau(j) gama v(j:n)
C                          = zw(j:n) - tau(j) v(j:n)^T zw(j:n) v(j:n).

         if ((abs(gama) .gt. macheps) .and.
     +        (abs(tau(j)) .gt. macheps)) then
            
            zw(j) = zw(j) - tau(j) * gama
            do i = j+1, n
               zw(i) = zw(i) - tau(j) * gama * A(i,j)
            end do
         end if
         
      end do

      end

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

      subroutine multZT(n, t, lda, A, tau, w, wd, ztw, macheps)

C     ARRAY ARGUMENTS
      integer n, t, lda
      double precision macheps
      
C     ARRAY ARGUMENTS
      double precision A(lda,t), tau(t), w(n), wd(n), ztw(n-t)

C     This routine multiplies vector w by matrix Z^T. Z is the matrix
C     formed by the last n-t columns of matrix Q (from QR factorization
C     of matrix A). 
C     The matrix Q is represented as a product of elementary reflectors
C     Q = H(1) H(2) . . . H(t), where t <= min(m,n).
C     Each H(i) has the form H(i) = I - tau * v * v'
C     where tau is a real scalar, and v is a real vector with
C     v(1:i-1) = 0 and v(i) = 1; v(i+1:t) is stored in A(i+1:t,i), and
C     tau in TAU(i).
C
C     On Entry
C
C     n        integer
C              number of rows of A
C
C     t        integer
C              n-t is the number of columns of Z
C
C     lda      integer
C              leading dimension of A
C
C     A        double precision A(lda,t)
C              matrix factorized by DGEQP3 routine. v(i+1:t) is
C              stored in A(i+1:t,i) (see comment above)
C
C     tau      double precision tau(t)
C              coeficient used to calculate reflectors (returned
C              by DGEQP3 routine)
C
C     w        double precision w(n)
C              vector to be multiplied by Z^T
C
C     wd       double precision wd(n)
C              working vector
C     
C     macheps  double precision
C              machine epsilon
C
C     On return
C
C     ztw      double precision ztw(n-t)
C              result of vector w multiplied by Z^T . ztw = Z^T w.
            
C     LOCAL SCALARS
      integer i, j
      double precision gama

C     If t = 0 then Z = I
      
      if (t .eq. 0) then
         do i = 1, n
            ztw(i) = w(i)
         end do
         return
      end if
      
      do i = 1, n
         wd(i) = w(i)
      end do
      
      do j = 1, t-1

C        Calculate gama = v(j:n)^T w(j:n).
         
         gama = wd(j)
         do i = j+1, n
            gama = gama + A(i,j) * wd(i)
         end do
         
C        Calculate wd(j:n) = wd(j:n) - tau(j) gama v(j:n)
C                          = wd(j:n) - tau(j) v(j:n)^T w(j:n) v(j:n).

         if ((abs(gama) .gt. macheps) .and.
     +        (abs(tau(j)) .gt. macheps)) then
            
            wd(j) = wd(j) - tau(j) * gama
            do i = j+1, n
               wd(i) = wd(i) - tau(j) * gama * A(i,j)
            end do
         end if
         
      end do

C     Multiplies vector w by last n-t rows of Hm

      gama = wd(t)
      do i = t+1, n
         gama = gama + A(i,t) * wd(i)
      end do

      do i = 1, n-t
         ztw(i) = wd(t+i)
      end do

      if ((abs(gama) .gt. macheps) .and.
     +     (abs(tau(t)) .gt. macheps)) then
         
         do i = n-t, 1, -1
            ztw(i) = ztw(i) - tau(t) * gama * A(i+t,t)
         end do
      end if
            
      end
      
C     *****************************************************************
C     *****************************************************************

      subroutine updateQR(n, nli, lda, A, tau, w, qw, macheps)

C     SCALAR ARGUMENTS      
      integer n, nli, lda
      double precision macheps
      
C     ARRAY ARGUMENTS      
      double precision A(lda,nli+1), tau(nli+1), w(n), qw(n)

C     This subroutine updates QR factorization of matrix Abar when
C     column w is to be inserted.
C
C     On Entry
C
C     n        integer
C              number of rows of A
C     
C     nli      integer
C              number of linear independent columns of A
C
C     lda      integer 
C              leading dimension of A
C
C     A        double precision A(lda,nli+1)
C              matrix factorized by DGEQP3 routine. v(i+1:m) is
C              stored in A(i+1:m,i) (see previous routine's comment)
C
C     tau      double precision tau(nli+1)
C              coeficient used to calculate reflectors (returned
C              by DGEQP3 routine)     
C
C     w        double precision w(n)
C              column to be inserted in A
C
C     qw       double precision qw(n)
C              working vector
C      
C     macheps  double precision
C              machine epsilon
C      
C     On Return
C
C     nli      integer
C              updated number of linear independent columns of A
C
C     A        double precision A(lda,nli+1)
C              updated QR factorization
C
C     tau      double precision tau(nli+1)
C              updated coeficients
      
C     LOCAL SCALARS
      integer i, j
      double precision tau2
      
C     Calculate qw = Q^T w
      
      call multQT(n, nli, lda, A, tau, w, qw, macheps)
      
C     Look for the first non-zero component of qw (from
C     the last position to the first).
      
      do i = n, 1, -1
         if (abs(qw(i)) .gt. macheps**(2.0d0/3.0d0)) then
            go to 10
         end if
      end do
      
C     If the first non-zero component of qw (from the last
C     position to the first) has index greater than nliact
C     it means the set of vectors formed by qw and the first
C     nliact columns of A is LI. In this case, we have to
C     update QR factorization of A. If the set is LD,
C     the factorization remains the same.
      
 10   if (i .gt. nli) then
         
C        Increase the number of LI columns of A.
         
         nli = nli + 1
         
C        Calculate reflector H such that H qw has non-zero 
C        elements only in indices from 1 to nliact.                  
         
         call DLARFG(n-nli+1, qw(nli), qw(nli+1), 1, tau2)
         
C        Place qw as nliact-th column of A. 
         
         do j = 1, n
            A(j,nli) = qw(j)
         end do
         tau(nli) = tau2
         
      end if
      
      end
      
C     ******************************************************************
C     ******************************************************************

      subroutine calcobj(nind,ind,x,n,xc,f,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer nind,n,inform
      double precision f

C     ARRAY ARGUMENTS
      integer ind(nind)
      double precision x(n),xc(n)

C     This subroutines computes the objective function. 
C
C     It is called from the reduced space (dimension nind), expands the
C     point x where the function will be evaluated and call the 
C     subroutine evalf to compute the objective function Finally, 
C     shrinks vector x to the reduced space. 
C
C     About subroutines named calc[something]. The subroutines whos 
C     names start with ``calc'' work in (are called from) the reduced 
C     space. Their tasks are (i) expand the arguments to the full space, 
C     (ii) call the corresponding ``eval'' subroutine (which works in 
C     the full space), and (iii) shrink the parameters again and also 
C     shrink a possible output of the ``eval'' subroutine. Subroutines
C     of this type are: calcobj, calcgr and calchess. 
C     The corresponding subroutines in the full space are the user 
C     defined subroutines evalf, evalg and evalhd.

C     LOCAL SCALARS
      integer i

C     Complete x

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

C     Expand x to the full space

      call expand(nind,ind,n,x)

C     Compute f calling the user supplied subroutine evalf

      call evalobj(n,x,f,inform)

C     Shrink x to the reduced space

      call shrink(nind,ind,n,x)

      return

      end

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

      subroutine calcgr(nind,ind,x,n,xc,g,gtype,macheps,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer gtype,inform,n,nind
      double precision macheps

C     ARRAY ARGUMENTS
      integer ind(nind)
      double precision x(n),xc(n),g(n)

C     This subroutine computes the gradient vector g of the objective 
C     function. 
C
C     It is called from the reduced space (dimension nind), expands the
C     point x where the gradient will be evaluated and calls the user 
C     supplied subroutine evalg to compute the gradient vector. Finally, 
C     shrinks vectors x and g to the reduced space. 
C
C     About subroutines named calc[something]. The subroutines whos 
C     names start with ``calc'' work in (are called from) the reduced 
C     space. Their tasks are (i) expand the arguments to the full space, 
C     (ii) call the corresponding ``eval'' subroutine (which works in 
C     the full space), and (iii) shrink the parameters again and also 
C     shrink a possible output of the ``eval'' subroutine. Subroutines
C     of this type are: calcobj, calcgr and calchess
C     The corresponding subroutines in the full space are the user 
C     defined subroutines evalf, evalg and evalhd.

C     LOCAL SCALARS
      integer i

C     Complete x

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

C     Expand x to the full space

      call expand(nind,ind,n,x)

C     Compute the gradient vector calling the user supplied subroutine 
C     evalg

      call evalgr(n,x,g,gtype,macheps,inform)

C     Shrink x and g to the reduced space

      call shrink(nind,ind,n,x)
      call shrink(nind,ind,n,g)

      return

      end

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

      subroutine calcpz(nind,ind,n,r,s,y,seucn,yeucn,sts,sty,lspgmi,
     +lspgma,samefa,gotp,pdiag,plspg,psmdy,psmdyty,z)

      implicit none

C     SCALAR ARGUMENTS
      logical gotp,samefa
      integer n,nind
      double precision lspgma,lspgmi,plspg,psmdyty,seucn,sts,sty,yeucn

C     ARRAY ARGUMENTS
      integer ind(nind)
      double precision r(n),s(n),pdiag(n),psmdy(n),y(n),z(n)

C     LOCAL SCALARS
      integer i

C     Complete r with zeroes

      do i = nind + 1,n
          r(i) = 0.0d0
      end do

C     Expand r to the full space

      call expand(nind,ind,n,r)

C     Solve P z = r

      call applyp(n,r,s,y,seucn,yeucn,sts,sty,lspgmi,lspgma,samefa,gotp,
     +pdiag,plspg,psmdy,psmdyty,z)

C     Shrink r and z to the reduced space

      call shrink(nind,ind,n,r)
      call shrink(nind,ind,n,z)

      end

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

      subroutine calchessp(nind,ind,x,p,g,n,xc,s,y,seucn,yeucn,sts,sty,
     +lspgmi,lspgma,samefa,gtype,hptype,aptype,hp,wdn1,macheps,inform,
     +goth,hlspg,hds,hstds)

      implicit none

C     This subroutine computes the product Hessian times vector p. As it
C     is called from the reduced space, it expands vectors x and p,  
C     calls subroutine evalhessp to compute the Hessian times vector p 
C     product, and shrinks vectors x, p and hp. 

C     SCALAR ARGUMENTS
      logical goth,samefa
      character * 6 aptype
      integer gtype,hptype,inform,n,nind
      double precision hlspg,hstds,lspgma,lspgmi,macheps,seucn,sts,sty,
     +        yeucn

C     ARRAY ARGUMENTS
      integer ind(nind)
      double precision g(n),hds(n),hp(n),p(n),wdn1(n),x(n),xc(n),s(n),
     +        y(n)

C     LOCAL SCALARS
      integer i

C     Complete p with zeroes

      do i = nind + 1,n
          p(i) = 0.0d0
      end do

C     Complete x

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

C     Expand x and p to the full space

      call expand(nind,ind,n,x)
      call expand(nind,ind,n,p)
      call expand(nind,ind,n,g)

C     Compute the Hessian-vector product

      call evalhessp(n,x,p,g,s,y,seucn,yeucn,sts,sty,lspgmi,lspgma,
     +samefa,gtype,hptype,aptype,hp,wdn1,macheps,inform,goth,hlspg,hds,
     +hstds)

C     Shrink x, p and hp to the reduced space

      call shrink(nind,ind,n,x)
      call shrink(nind,ind,n,p)
      call shrink(nind,ind,n,g)
      call shrink(nind,ind,n,hp)
      
      end

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

      subroutine shrink(nind,ind,n,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 n,nind

C     ARRAY ARGUMENTS
      integer ind(nind)
      double precision v(n)

C     Parameters of the subroutine:
C     =============================
C
C     On Entry:
C     =========
C
C     NIND integer: Dimension of the reduced space.
C     ------------
C
C     IND integer ind(nind)
C     ---------------------
C
C     Components ind(1)-th, ..., ind(nind)-th are the components that 
C     belong to the reduced space.
C
C     N integer: Dimension of the full space.
C     ---------
C
C     V double precision v(n): Vector to be shrinked.
C     -----------------------
C
C     On Return:
C     ==========
C
C     V double precision v(n): Shrinked vector.
C     -----------------------

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

      return

      end

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

      subroutine expand(nind,ind,n,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 n, nind

C     ARRAY ARGUMENTS
      integer ind(nind)
      double precision v(n)

C     Parameters of the subroutine:
C     =============================
C
C     On Entry:
C     =========
C
C     NIND integer: Dimension of the reduced space.
C     ------------
C
C     IND integer ind(nind)
C     ---------------------
C
C     Components ind(1)-th, ..., ind(nind)-th are the components that 
C     belong to the reduced space.
C
C     N integer: Dimension of the full space.
C     ---------
C
C     V double precision v(n): Vector to be expanded.
C     -----------------------
C
C     On Return:
C     ==========
C
C     V double precision v(n): Expanded vector.
C     -----------------------

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
     
      return

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

      double precision function norm2s(n,x)

C     This subroutine computes the squared Euclidian norm of an 
C     n-dimensional vector.

C     SCALAR ARGUMENTS
      integer n

C     ARRAY ARGUMENTS
      double precision x(n)

C     Parameters of the subroutine:
C     =============================
C
C     On Entry:
C     =========
C
C     N integer: Dimension.
C     ---------
C
C     X double precision x(n): Vector.
C     -----------------------
C
C     On Return:
C     ==========
C
C     The function return the squared Euclidian norm of the 
C     n-dimensional vector x.

      double precision hsldnrm2

      norm2s = hsldnrm2(n,x,1) ** 2

      return 

      end

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

      DOUBLE PRECISION FUNCTION HSLDNRM2(N,DX,INCX)
      DOUBLE PRECISION ZERO,ONE
      PARAMETER (ZERO=0.0D0,ONE=1.0D0)
      DOUBLE PRECISION CUTLO,CUTHI
      PARAMETER (CUTLO=8.232D-11,CUTHI=1.304D19)
      INTEGER INCX,N
      DOUBLE PRECISION DX(*)
      DOUBLE PRECISION HITEST,SUM,XMAX
      INTEGER I,J,NEXT,NN
      INTRINSIC DABS,DSQRT,FLOAT
      IF (N.GT.0) GO TO 10
      HSLDNRM2 = ZERO
      GO TO 300
   10 ASSIGN 30 TO NEXT
      SUM = ZERO
      NN = N*INCX
      I = 1
   20 GO TO NEXT
   30 IF (DABS(DX(I)).GT.CUTLO) GO TO 85
      ASSIGN 50 TO NEXT
      XMAX = ZERO
   50 IF (DX(I).EQ.ZERO) GO TO 200
      IF (DABS(DX(I)).GT.CUTLO) GO TO 85
      ASSIGN 70 TO NEXT
      GO TO 105
  100 I = J
      ASSIGN 110 TO NEXT
      SUM = (SUM/DX(I))/DX(I)
  105 XMAX = DABS(DX(I))
      GO TO 115
   70 IF (DABS(DX(I)).GT.CUTLO) GO TO 75
  110 IF (DABS(DX(I)).LE.XMAX) GO TO 115
      SUM = ONE + SUM* (XMAX/DX(I))**2
      XMAX = DABS(DX(I))
      GO TO 200
  115 SUM = SUM + (DX(I)/XMAX)**2
      GO TO 200
   75 SUM = (SUM*XMAX)*XMAX
   85 HITEST = CUTHI/DFLOAT(N)
      DO 95 J = I,NN,INCX
        IF (DABS(DX(J)).GE.HITEST) GO TO 100
   95 SUM = SUM + DX(J)**2
      HSLDNRM2 = DSQRT(SUM)
      GO TO 300
  200 CONTINUE
      I = I + INCX
      IF (I.LE.NN) GO TO 20
      HSLDNRM2 = XMAX*DSQRT(SUM)
  300 CONTINUE
      RETURN
      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     ******************************************************************
      
      DOUBLE PRECISION FUNCTION D1MACH(I)
      INTEGER I
C
C  DOUBLE-PRECISION MACHINE CONSTANTS
C  D1MACH( 1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE.
C  D1MACH( 2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE.
C  D1MACH( 3) = B**(-T), THE SMALLEST RELATIVE SPACING.
C  D1MACH( 4) = B**(1-T), THE LARGEST RELATIVE SPACING.
C  D1MACH( 5) = LOG10(B)
C
      INTEGER SMALL(2)
      INTEGER LARGE(2)
      INTEGER RIGHT(2)
      INTEGER DIVER(2)
      INTEGER LOG10(2)
      INTEGER SC, CRAY1(38), J
      COMMON /D9MACH/ CRAY1
      SAVE SMALL, LARGE, RIGHT, DIVER, LOG10, SC
      DOUBLE PRECISION DMACH(5)
      EQUIVALENCE (DMACH(1),SMALL(1))
      EQUIVALENCE (DMACH(2),LARGE(1))
      EQUIVALENCE (DMACH(3),RIGHT(1))
      EQUIVALENCE (DMACH(4),DIVER(1))
      EQUIVALENCE (DMACH(5),LOG10(1))
C  THIS VERSION ADAPTS AUTOMATICALLY TO MOST CURRENT MACHINES.
C  R1MACH CAN HANDLE AUTO-DOUBLE COMPILING, BUT THIS VERSION OF
C  D1MACH DOES NOT, BECAUSE WE DO NOT HAVE QUAD CONSTANTS FOR
C  MANY MACHINES YET.
C  TO COMPILE ON OLDER MACHINES, ADD A C IN COLUMN 1
C  ON THE NEXT LINE
      DATA SC/0/
C  AND REMOVE THE C FROM COLUMN 1 IN ONE OF THE SECTIONS BELOW.
C  CONSTANTS FOR EVEN OLDER MACHINES CAN BE OBTAINED BY
C          mail netlib@research.bell-labs.com
C          send old1mach from blas
C  PLEASE SEND CORRECTIONS TO dmg OR ehg@bell-labs.com.
C
C     MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES.
C      DATA SMALL(1),SMALL(2) / O402400000000, O000000000000 /
C      DATA LARGE(1),LARGE(2) / O376777777777, O777777777777 /
C      DATA RIGHT(1),RIGHT(2) / O604400000000, O000000000000 /
C      DATA DIVER(1),DIVER(2) / O606400000000, O000000000000 /
C      DATA LOG10(1),LOG10(2) / O776464202324, O117571775714 /, SC/987/
C
C     MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING
C     32-BIT INTEGERS.
C      DATA SMALL(1),SMALL(2) /    8388608,           0 /
C      DATA LARGE(1),LARGE(2) / 2147483647,          -1 /
C      DATA RIGHT(1),RIGHT(2) /  612368384,           0 /
C      DATA DIVER(1),DIVER(2) /  620756992,           0 /
C      DATA LOG10(1),LOG10(2) / 1067065498, -2063872008 /, SC/987/
C
C     MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES.
C      DATA SMALL(1),SMALL(2) / O000040000000, O000000000000 /
C      DATA LARGE(1),LARGE(2) / O377777777777, O777777777777 /
C      DATA RIGHT(1),RIGHT(2) / O170540000000, O000000000000 /
C      DATA DIVER(1),DIVER(2) / O170640000000, O000000000000 /
C      DATA LOG10(1),LOG10(2) / O177746420232, O411757177572 /, SC/987/
C
C     ON FIRST CALL, IF NO DATA UNCOMMENTED, TEST MACHINE TYPES.
      IF (SC .NE. 987) THEN
         DMACH(1) = 1.D13
         IF (      SMALL(1) .EQ. 1117925532
     *       .AND. SMALL(2) .EQ. -448790528) THEN
*           *** IEEE BIG ENDIAN ***
            SMALL(1) = 1048576
            SMALL(2) = 0
            LARGE(1) = 2146435071
            LARGE(2) = -1
            RIGHT(1) = 1017118720
            RIGHT(2) = 0
            DIVER(1) = 1018167296
            DIVER(2) = 0
            LOG10(1) = 1070810131
            LOG10(2) = 1352628735
         ELSE IF ( SMALL(2) .EQ. 1117925532
     *       .AND. SMALL(1) .EQ. -448790528) THEN
*           *** IEEE LITTLE ENDIAN ***
            SMALL(2) = 1048576
            SMALL(1) = 0
            LARGE(2) = 2146435071
            LARGE(1) = -1
            RIGHT(2) = 1017118720
            RIGHT(1) = 0
            DIVER(2) = 1018167296
            DIVER(1) = 0
            LOG10(2) = 1070810131
            LOG10(1) = 1352628735
         ELSE IF ( SMALL(1) .EQ. -2065213935
     *       .AND. SMALL(2) .EQ. 10752) THEN
*               *** VAX WITH D_FLOATING ***
            SMALL(1) = 128
            SMALL(2) = 0
            LARGE(1) = -32769
            LARGE(2) = -1
            RIGHT(1) = 9344
            RIGHT(2) = 0
            DIVER(1) = 9472
            DIVER(2) = 0
            LOG10(1) = 546979738
            LOG10(2) = -805796613
         ELSE IF ( SMALL(1) .EQ. 1267827943
     *       .AND. SMALL(2) .EQ. 704643072) THEN
*               *** IBM MAINFRAME ***
            SMALL(1) = 1048576
            SMALL(2) = 0
            LARGE(1) = 2147483647
            LARGE(2) = -1
            RIGHT(1) = 856686592
            RIGHT(2) = 0
            DIVER(1) = 873463808
            DIVER(2) = 0
            LOG10(1) = 1091781651
            LOG10(2) = 1352628735
         ELSE IF ( SMALL(1) .EQ. 1120022684
     *       .AND. SMALL(2) .EQ. -448790528) THEN
*           *** CONVEX C-1 ***
            SMALL(1) = 1048576
            SMALL(2) = 0
            LARGE(1) = 2147483647
            LARGE(2) = -1
            RIGHT(1) = 1019215872
            RIGHT(2) = 0
            DIVER(1) = 1020264448
            DIVER(2) = 0
            LOG10(1) = 1072907283
            LOG10(2) = 1352628735
         ELSE IF ( SMALL(1) .EQ. 815547074
     *       .AND. SMALL(2) .EQ. 58688) THEN
*           *** VAX G-FLOATING ***
            SMALL(1) = 16
            SMALL(2) = 0
            LARGE(1) = -32769
            LARGE(2) = -1
            RIGHT(1) = 15552
            RIGHT(2) = 0
            DIVER(1) = 15568
            DIVER(2) = 0
            LOG10(1) = 1142112243
            LOG10(2) = 2046775455
         ELSE
            DMACH(2) = 1.D27 + 1
            DMACH(3) = 1.D27
            LARGE(2) = LARGE(2) - RIGHT(2)
            IF (LARGE(2) .EQ. 64 .AND. SMALL(2) .EQ. 0) THEN
               CRAY1(1) = 67291416
               DO 10 J = 1, 20
                  CRAY1(J+1) = CRAY1(J) + CRAY1(J)
 10               CONTINUE
               CRAY1(22) = CRAY1(21) + 321322
               DO 20 J = 22, 37
                  CRAY1(J+1) = CRAY1(J) + CRAY1(J)
 20               CONTINUE
               IF (CRAY1(38) .EQ. SMALL(1)) THEN
*                  *** CRAY ***
                  CALL I1MCRY(SMALL(1), J, 8285, 8388608, 0)
                  SMALL(2) = 0
                  CALL I1MCRY(LARGE(1), J, 24574, 16777215, 16777215)
                  CALL I1MCRY(LARGE(2), J, 0, 16777215, 16777214)
                  CALL I1MCRY(RIGHT(1), J, 16291, 8388608, 0)
                  RIGHT(2) = 0
                  CALL I1MCRY(DIVER(1), J, 16292, 8388608, 0)
                  DIVER(2) = 0
                  CALL I1MCRY(LOG10(1), J, 16383, 10100890, 8715215)
                  CALL I1MCRY(LOG10(2), J, 0, 16226447, 9001388)
               ELSE
                  WRITE(*,9000)
                  STOP 779
                  END IF
            ELSE
               WRITE(*,9000)
               STOP 779
               END IF
            END IF
         SC = 987
         END IF
*    SANITY CHECK
      IF (DMACH(4) .GE. 1.0D0) STOP 778
      IF (I .LT. 1 .OR. I .GT. 5) THEN
         WRITE(*,*) 'D1MACH(I): I =',I,' is out of bounds.'
         STOP
         END IF
      D1MACH = DMACH(I)
      RETURN
 9000 FORMAT(/' Adjust D1MACH by uncommenting data statements'/
     *' appropriate for your machine.')
* /* Standard C source for D1MACH -- remove the * in column 1 */
*#include <stdio.h>
*#include <float.h>
*#include <math.h>
*double d1mach_(long *i)
*{
*	switch(*i){
*	  case 1: return DBL_MIN;
*	  case 2: return DBL_MAX;
*	  case 3: return DBL_EPSILON/FLT_RADIX;
*	  case 4: return DBL_EPSILON;
*	  case 5: return log10((double)FLT_RADIX);
*	  }
*	fprintf(stderr, "invalid argument: d1mach(%ld)\n", *i);
*	exit(1); return 0; /* some compilers demand return values */
*}
      END
      SUBROUTINE I1MCRY(A, A1, B, C, D)
**** SPECIAL COMPUTATION FOR OLD CRAY MACHINES ****
      INTEGER A, A1, B, C, D
      A1 = 16777216*B + C
      A = 16777216*A1 + D
      END
