C     Solves the constrained minimization problem
C
C                         Minimize f(x)
C
C                         subject to 
C                                  Ai x  = bi, i = 1, ..., meq
C                                  Ai x >= bi, i = meq+1, ..., m
C                                  l <= x <= u
C     
C     using a method of active constraints.
C
C     Subroutine evalf must be supplied by the user to evaluate the 
C     objective function. The prototype of evalf subroutine must be
C
C           subroutine evalf(n, x, f, flag)
C
C     C     On Entry
C     C
C     C     n     integer
C     C           number of variables
C     C
C     C     x     double precision x(n)
C     C           current point
C     C
C     C     On Return
C     C
C     C     f     double precision
C     C           objective function value at x
C     C
C     C     flag  integer
C     C           0 means ''no errors''
C     C         -90 means ''there was an error in the objective 
C     C             function calculation''.
C     C
C     C     SCALAR ARGUMENTS
C           integer flag, n
C           double precision f
C     
C     C     ARRAY ARGUMENTS
C           double precision x(n)
C
C     C     ''Here it should be the body of evalf subroutine that saves 
C     C     in f the objective function value at x. Moreover, it sets 
C     C     flag equal to 0 if the calculation was successfully done and 
C     C     sets flag equal to any other value different from 0 if the 
C     C     objective function is not well defined at the current point 
C     C     x.''
C  
C           end
C
C     Subroutine evalg to calculate the gradient of the objective 
C     function may be supplied by the user or not, depending on the 
C     value of gtype argument (gtype equal to 0 means that the evalg 
C     subroutine will be supplied by the user and gtype equal to 1 means 
C     that an internal GENLIN subroutine will be used to estimate the 
C     gradient vector by central finite differences). In any case, a 
C     subroutine named evalg with the following prototype must 
C     present.
C
C           subroutine evalg(n, x, g, flag)
C
C     C     On Entry
C     
C     C     n     integer
C     C           number of variables
C     C
C     C     x     double precision x(n)
C     C           current point
C     C
C     C     On Return
C     C
C     C     g     double precision g(n)
C     C           gradient of the objective function at x
C     C
C     C     flag  integer
C     C           0 means ''no errors'',
C     C         -92 means ''there was an error in the gradient 
C     C             calculation''.
C     C
C     C     SCALAR ARGUMENTS
C           integer flag, n
C     
C     C     ARRAY ARGUMENTS
C           double precision g(n), x(n)
C
C     C     ''Here it should be the body of evalg subroutine that 
C     C     saves in g the gradient vector of the objective function at 
C     C     x. Moreover, it sets flag equal to 0 if the calculation was 
C     C     successfully done and sets flag equal to any other value 
C     C     different from 0 if the gradient vector is not well defined 
C     C     at the current point x. If GENLIN gtype argument was setted 
C     C     to 1, i.e., the finite difference approximation provided by 
C     C     GENLIN will be used, then this subroutine must even be 
C     C     present for compilation purpose but it will never be 
C     C     called.''
C  
C           end
C
C     Subroutine evalh to calculate the Hessian matrix of the objective 
C     function may be supplied by the user or not, depending on the 
C     value of hptype argument (hptype equal to 1 means that the evalh 
C     subroutine will be supplied by the user and other values mean
C     that an internal GENLIN subroutine will be used to estimate the 
C     Hessian matrix or the matrix-vector produt using Hessian matrix). 
C     In any case, a subroutine named evalh with the following prototype 
C     must present. Note: just the lower triangular part of H need to be
C     defined.
C     
C           subroutine evalh(n, x, ldh, H, flag)
C
C     C     On Entry
C     C
C     C     n     integer
C     C           number of variables
C     C
C     C     x     double precision x(n)
C     C           current point
C     C
C     C     ldh   integer
C     C           leading dimension of H
C     C
C     C     On Return
C     C
C     C     H     double precision H(ldh,n)
C     C           Hessian at x
C     C
C     C     flag  integer
C     C           0 means ''no errors'',
C     C         -94 means ''there was an error in the Hessian 
C     C             calculation''. 
C     
C     C     SCALAR ARGUMENTS
C           integer n, ldh, flag
C     
C     C     ARRAY ARGUMENTS
C           double precision x(n), H(ldh,n)
C     
C     C     ''Here it should be the body of evalh subroutine that saves 
C     C     in H the Hessian of the objective function. Moreover, it
C     C     sets flag equal to 0 if the calculation was successfully
C     C     done and sets flag equal to any other value different from
C     C     0 if the Hessian matrix is not well defined at the current
C     C     point x.''
C  
C           end
C
C     Subroutine evalhd to calculate of the Hessian of the objective 
C     function times a given vector may be supplied by the user or not, 
C     depending on the value of hptype argument (hptype equal to 0 
C     means that the evalhd subroutine will be supplied by the user and 
C     other values mean that an internal GENLIN subroutine will be
C     used to estimate the product by incremental quotients). In any 
C     case, a subroutine named evalhd with the following prototype must 
C     present.
C
C           subroutine evalhd(nind, ind, n, x, d, hd, flag)
C
C     C     On Entry:
C     C
C     C     nind  integer
C     C           number of component of the Hessian-vector product that
C     C           must be computed
C     C
C     C     ind   integer ind(nind)
C     C           the component that must be computed are ind(1)-th ... 
C     C           ind(nind)-th
C     C
C     C     n     integer
C     C           number of variables
C     C
C     C     x     double precision x(n)
C     C           current point
C     C
C     C     d     double precision d(n)
C     C           vector of the Hessian-vector product
C     C
C     C     On Return
C     C
C     C     hd    double precision g(n)
C     C           Hessian-vector product
C     C
C     C     flag  integer
C     C           0 means ''no errors'',
C     C           any other value means ''there was an error in the 
C     C           product calculation''. Just as an example, as it has
C     C           no sense that an error occurs in a matrix-vector
C     C           product, the error could happen in the Hessian
C     C           calculation. But the possible errors will depend
C     C           on the way this Hessian-vector product is computed
C     C           or approximated.
C
C     C     SCALAR ARGUMENTS
C           integer flag, n, nind
C     
C     C     ARRAY ARGUMENTS
C           integer ind(nind)
C           double precision d(n), hd(n), x(n)
C     
C     C     ''Here it should be the body of evalhd subroutine that saves 
C     C     in hd the product of the Hessian of the objective function 
C     C     times vector d. Moreover, it sets flag equal to 0 if the 
C     C     calculation was successfully done and sets flag equal to any 
C     C     other value different from 0 if the Hessian matrix is not 
C     C     well defined at the current point x. If GENLIN hptype 
C     C     argument was setted to 1, i.e., the incremental quotients 
C     C     approximation provided by GENLIN will be used, then this 
C     C     subroutine must even be present for compilation purposes 
C     C     but it will never be called.''
C  
C           end
C
C     This subroutine must be coded by the user, taking into account
C     that only nind components of d are nonnull and that ind is the
C     set of indices of those components. In other words, the user
C     must write evalhd in such a way that hd is the vector whose i-th
C     entry is
C 
C               hd(i) = \Sum_{j=1}^{nind} H_{i,ind(j)} d_ind(j)
C
C     Moreover, the only components of hd that must be computed are 
C     those which correspond to the indices ind(1),...,ind(nind). 
C     However, observe that it must be assumed that, in d, the whole 
C     dense vector is present, with its n components, even the null 
C     ones. So, if the user decides to code evalhd without taking into 
C     account the presence of ind and nind, it can be easily done. A 
C     final observation: probably, if nind is close to n, it is not 
C     worthwhile to use ind, due to the cost of accessing the correct 
C     indices. 
C
C     Example: Assume that H is dense. The main steps of evalhd could 
C     be:
C
C          do i = 1,nind
C              indi     = ind(i)
C              hd(indi) = 0.0d0
C              do j = 1,nind
C                  indj     = ind(j)
C                  hd(indi) = hd(indi) + H(indi,indj) * d(indj)
C              end do
C          end do
C
C     Description of the GENLIN arguments:
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     m        integer
C     meq      integer
C     lda      integer
C     A        double precision(lda,n)
C     b        double precision(m)
C              These five parameters are used but not modified by 
C              GENLIN. m is the number of linear constraints in the
C              original problem; meq is the number of linear equality
C              constraints; A is the matrix of coeficients of the linear
C              constraits; and b is the right-hand side of the linear
C              constraints   
C     
C     epsgpen  double precision
C              epsgpen means EPSilon for the Projected Gradient Euclidian
C              Norm. It is a small positive number for declaring 
C              convergence when the Euclidian norm of the continuous 
C              projected gradient is less than or equal to epsgpen
C
C              RECOMMENDED: epsgpen = 1.0d-05
C
C              CONSTRAINTS: epsgpen >= 0.0
C
C     epsgpsn  double precision
C              epsgpsn means EPSilon for the Projected Gradient Sup Norm.
C              It is a small positive number for declaring convergence 
C              when the sup norm of the continuous projected gradient is 
C              less than or equal to epsgpsn
C
C              RECOMMENDED: epsgpsn = 1.0d-05
C
C              CONSTRAINTS: epsgpsn >= 0.0
C
C     epsgzsn  double precision
C              a small positive number for declaring convergence of inner
C              algorithm when the sup norm of the projected gradient onto 
C              null space of active linear constraints is less than or 
C              equal to epsgzsn
C     
C              RECOMMENDED: epsgzsn = 1.0d-05
C
C              CONSTRAINTS: epsgzsn >= 0.0
C     
C     maxitnfp integer
C              maxitnfp means MAXimum of ITerations with No Function 
C              Progress. See below for more details.
C
C     epsnfp   double precision
C              epsnfp means EPSilon for No Function Progress. It is a
C              small positive number for declaring ''lack of progress in 
C              the objective function value'' if f(x_k) - f(x_{k+1}) <= 
C              epsnfp * max{ f(x_j) - f(x_{j+1}, j < k } during maxitnfp 
C              consecutive iterations. This stopping criterion may be 
C              inhibited setting maxitnfp equal to maxit.
C
C              RECOMMENDED: maxitnfp = 15 and epsnfp = 1.0d-05
C
C              CONSTRAINTS: maxitnfp >= 1 and epsnfp >= 0.0
C     
C     maxitngp integer
C              maxitngp means MAXimum of ITerations with No Gradient
C              Progress. If the order of the Euclidian norm of the 
C              continuous projected gradient did not change during 
C              maxitngp consecutive iterations then the execution stops. 
C
C              RECOMMENDED: maxitngp = 15
C
C              CONSTRAINTS: maxitngp >= 1
C
C     fmin     double precision
C              function value for the stopping criteria f <= fmin
C
C              There is a stopping criterion that stops GENLIN 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 = -1.0d+20
C
C              CONSTRAINTS: there are no constraints for this argument
C
C     maxit    integer
C              maximum number of allowed iterations
C
C              RECOMMENDED: maxit = 2000
C
C              CONSTRAINTS: maxit >= 0
C
C     maxfc    integer
C              maximum allowed number of functional evaluations
C
C              RECOMMENDED: maxfc = 5 * maxit
C
C              CONSTRAINTS: maxfc >= 1
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     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( nred ) ) when the method is
C              far from the solution to nred when the method is near to 
C              the solution, where nred is the number of variables of the 
C              subproblem (equal to the number of free variables minus the
C              number of LI linear constraints). 
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     cgscre   integer
C              See below
C     
C     cggpnf   double precision
C              cgscre means conjugate gradient stopping criterion 
C              relation, and cggpnf means Conjugate Gradients projected 
C              gradient final norm. Both are related to a stopping 
C              criterion of Conjugate Gradients. This stopping criterion 
C              depends on the norm of the residual of the linear system. 
C              The norm of the residual should be less or equal than a 
C              ''small'' quantity which decreases as we are 
C              approximating the solution of the minimization problem 
C              (near the solution, better the truncated-Newton direction 
C              we aim). Then, the log of the required accuracy requested 
C              to Conjugate Gradient has a linear dependence on the log 
C              of the norm of the continuous projected gradient. This 
C              linear relation uses the squared Euclidian norm of the 
C              projected gradient if cgscre is equal to 1 and uses the 
C              sup-norm if cgscre is equal to 2. In addition, the 
C              precision required to CG is equal to cgepsi (conjugate 
C              gradient initial epsilon) at x0 and cgepsf (conjugate 
C              gradient final epsilon) when the Euclidian- or sup-norm 
C              of the projected gradient is equal to cggpnf (conjugate 
C              gradients projected gradient final norm) which is an 
C              estimation of the value of the Euclidian- or sup-norm of 
C              the projected gradient at the solution.
C
C              RECOMMENDED: cgscre = 1, cggpnf = epsgpen; or
C                           cgscre = 2, cggpnf = epsgpsn.
C
C              CONSTRAINTS:  allowed values for cgscre are just 1 or 2
C                            cggpnf >= 0.0
C
C     cgepsi   double precision
C              See below
C
C     cgepsf   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     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     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     etaext   double precision
C              Constant for the extrapolation. When extrapolating we 
C              try alpha_new = alpha * etaext
C
C              RECOMMENDED: etaext = 2.0
C
C              CONSTRAINTS: etaext > 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     maxextrap integer
C              Constant to limit the number of extrapolations in the 
C              Truncated Newton direction.
C
C              RECOMMENDED: maxextrap = 10
C
C              CONSTRAINTS: maxextrap >= 0
C
C     intype   integer
C              type of inner algorithm to be used. 1 means that the
C              inner algorithm of GENCAN (conjugated gradients) will be
C              used. Otherwise, BETRA's inner algorithm will be used
C              (trust-region method with spg)
C     
C     gtype    integer
C              gtype indicates in which way the gradient of the 
C              objective function will be computed. If the user have 
C              been implemented the user-supplied evalg subroutine to 
C              compute the gradient of the objective function then 
C              gtype argument must be set to 0 (ZERO) and the user-
C              supplied evalg subroutine will be called by GENLIN any 
C              time the gradient would be required.
C
C              RECOMMENDED: gtype = 0 (provided you have the evalg 
C                           subroutine)
C
C              CONSTRAINTS: allowed values are just 0 or 1.
C
C     hptype   integer
C              The way in which the product of the Hessian matrix
C              by a vector will be done depends on the value of the 
C              parameter hptype in the following way:
C
C              = 0, means that a subroutine provided by the user will be
C                   used to compute the Hessian-vector product.
C
C              = 1, 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              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     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     scale    logical
C              true iff constraint matrix A should be scaled
C
C              RECOMMENDED: scale = TRUE
C
C              CONSTRAINTS: allowed values are just TRUE or FALSE.      
C      
C     scmaxcnd double precision
C              parameter to decide if rows and/or columns of A should 
C              be scaled
C
C              RECOMMENDED: scmaxcnd = 0.2d+00
C
C              CONSTRAINTS: scmaxcnd >= 0.0d+00
C
C     scmaxal  double precision
C              parameter to decide if rows and/or columns of A should 
C              be scaled
C
C              RECOMMENDED: scmaxal = 1.0d+05
C
C              CONSTRAINTS: scmaxal >= 0.0d+00
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, GENLIN 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
C              and linear constraints will be printed
C
C              RECOMMENDED: ncomp = 5
C
C              CONSTRAINTS: ncomp >= 0
C
C     s        double precision s(n)
C     y        double precision y(n)
C     d        double precision d(n)
C     dz       double precision dz(n)      
C     ind      integer ind(n)
C     ind2     integer ind2(n)      
C     gp       double precision gp(n)
C     gi       double precision gi(n)
C     gz       double precision gz(n)
C     srow     double precision srow(m)
C     scol     double precision scol(n)
C     scx      double precision scx(n)
C     iact     integer iact(m)
C     rbdind   integer rbdind(n+m)
C     tau      double precision tau(m)
C     wi1      integer wi1(n+n+m)
C     wd1      double precision wd1(n)
C     wd2      double precision wd2(n)
C     wd3      double precision wd3(n)
C     wd4      double precision wd4(max{m,n})
C     wd5      double precision wd5(n)
C     wd6      double precision wd6(n)
C     wd7      double precision wd7(lwd7)
C     wd8      double precision wd8(n)
C     wd9      double precision wd9(n)
C     wd10     double precision wd10(n)      
C              working vectors
C     
C     lwd7     integer
C              size of wd7
C     
C              CONSTRAINTS: lwd7 >= max(3m+1,1.5*n*n+10*n+m)
C
C     ldh      integer
C              leading dimension of H
C
C     H        double precision H(ldh,n)
C              working matrix
C
C     ldabar   integer
C              leading dimension of Abar
C
C     Abar     double precision Abar(ldabar,m)
C              working matrix      
C
C     ktest    integer
C              the test to decide to abandon the current face or not is
C              performed on each ktest iterations
C      
C     eta      double precision
C              Constant for deciding abandon the current face or not. We 
C              abandon the current face if the norm of the internal 
C              gradient (here, internal components of the continuous 
C              projected gradient) is smaller than ( 1 - eta ) times the 
C              norm of the continuous projected gradient. Using eta = 
C              0.9 is a rather conservative strategy in the sense that 
C              internal iterations are preferred over SPG iterations. 
C
C              RECOMMENDED: eta = 0.1
C
C              CONSTRAINTS: 0.0 < eta < 1.0
C     
C     delmin   double precision
C              Smaller Conjugate Gradients ''trust radius'' to compute 
C              the Truncated Newton direction
C
C              RECOMMENDED: delmin = 1.0d+04
C
C              CONSTRAINTS: delmin > 0.0
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     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 = 1.0d-06
C
C              CONSTRAINTS: 0.0 < theta < 1.0
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     beta     double precision
C              Constant for the beta condition <dk, g(xk + dk)>  < beta 
C              * <dk,gk>. If (xk + dk) satisfies the Armijo condition 
C              but does not satisfy the beta condition then the point is 
C              accepted, but if it satisfied the Armijo condition and 
C              also satisfies the beta condition then we know that there 
C              is the possibility for a successful extrapolation
C
C              RECOMMENDED: beta = 0.5
C
C              CONSTRAINTS: 0.0 < beta < 1.0.
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     rhoms    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              box of constraints)
C
C              RECOMMENDED: rhoms = 9.0d-01
C
C     mseps    double precision
C              tolerance for More-Sorensen algorithm
C
C              RECOMMENDED: mseps = 1.0d-05
C
C     msmaxit  integer
C              maximum allowed number of MEQB iterations
C
C              RECOMMENDED: msmaxit = 100
C
C     phieps   double precision
C              allowed error in comparing the quadratic model value to 
C              zero
C
C              RECOMMENDED: phieps = 1.0d-05
C
C     sigms    double precision
C              allowed error to trust-region subproblem solution 
C
C              RECOMMENDED: sigms = 2.0d-01
C
C     trgamma  double precision
C              sufficient decrease occurs when ared >= trgamma*pred 
C
C              RECOMMENDED: trgamma = 1.0d-01
C
C     delini   double precision
C              used to calculate the initial trust-region radius 
C
C              RECOMMENDED: delini = 1.0d+02
C
C     trdelmin double precision
C              minimum value for trust-region radius (delta) in the 
C              beginning of each iteration
C
C              RECOMMENDED: delmin = 1.0d-04
C
C     trdelmax double precision
C              maximum value for trust-region radius (delta) on each 
C              iteration
C
C              RECOMMENDED: delmin = 1.0d+15
C
C     promaxit integer
C              maximum allowed number of iterations for projection
C      
C              RECOMMENDED: promaxit = 5000
C
C              CONSTRAINTS: promaxit > 0
C
C     projeps  double precision
C              error allowed in projection
C
C              RECOMMENDED: projeps = 1.0d-08
C
C              CONSTRAINTS: projeps > 0
C     
C     ceps     double precision
C              error allowed to consider some point x unfeasible
C              (with respect to linear constaints)
C
C              RECOMMENDED: ceps = 1.0d-05
C
C              CONSTRAINTS: ceps > 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 1.0d+99
C
C     On Return
C
C     x        double precision x(n)
C              Final estimation to the solution
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     gpeucn2  double precision
C              Squared Euclidian norm of the continuous projected 
C              gradient at the final estimation
C
C     gpsupn   double precision
C              the same as before but with sup-norm
C
C     nit      integer
C              number of iterations
C
C     nef      integer
C              number of function evaluations   
C
C     neg      integer
C              number of gradient evaluations   
C
C     ncg      integer
C              number of Conjugate Gradients iterations   
C     
C     nch      integer
C              number of Cholesky decompositions
C      
C     spgnit   integer
C              number of Spectral Projected Gradient iterations
C
C     spgnef   integer
C              number of functional evaluations along Spectral Projected
C              Gradient directions
C
C     tnnit    integer
C              number of Truncated-Newton iterations
C
C     tnnef    integer
C              number of functional evaluations along Truncated-Newton
C              directions
C     
C     tnintcnt integer
C              number of times a backtracking in a Truncated-Newton
C              direction was needed
C
C     tnexgcnt integer
C              number of times an extrapolation in a Truncated-Newton
C              direction successfully decreased the objective funtional
C              value
C
C     tnexbcnt integer
C              number of times an extrapolation was aborted in the first
C              extrapolated point by an increase in the objective 
C              functional value
C
C     tnstpcnt integer
C              number of times the Newton point was accepted (without
C              interpolations nor extrapolations)
C
C     tnintfe  integer
C              number of functional evaluations used in interpolations 
C              along Truncated-Newton directions
C
C     tnexgfe  integer
C              number of functional evaluations used in successful 
C              extrapolations along Truncated-Newton directions
C
C     tnexbfe  integer
C              number of functional evaluations used in unsuccessful 
C              extrapolations along Truncated-Newton directions
C
C     spginit  integer
C              number of inner Spectral Projected Gradient iterations     
C      
C     spginef  integer
C              number of functional evaluations along inner Spectral 
C              Projected Gradient directions
C      
C     trnit    integer
C              number of Trus-Region iterations
C      
C     trnef    integer
C              number of functional evaluations along Trust-Region
C              directions
C      
C     trexgcnt integer
C              number of functional evaluations used in successful 
C              extrapolations along Trust-Region directions
C      
C     trexbcnt integer
C              number of functional evaluations used in unsuccessful 
C              extrapolations along Trust-Region directions
C      
C     trexgfe  integer
C              number of functional evaluations used in interpolations 
C              along Trust-Region directions
C      
C     trexbfe  integer
C              number of functional evaluations used in unsuccessful 
C              extrapolations along Trust-Region 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 small Euclidian norm of the 
C                  continuous projected gradient (smaller than epsgpen);
C
C              1 = 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              3 = the algorithm stopped because the order of the 
C                  Euclidian norm of the continuous projected gradient 
C                  did not change during maxitngp consecutive 
C                  iterations. Probably, we are asking for an 
C                  exaggerated small norm of continuous projected 
C                  gradient for declaring convergence. If desired, set
C                  maxitngp equal to maxit to inhibit this stopping 
C                  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 point unfeasible. 
C                  Probably, we are asking for little accuracy in
C                  projection;
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, and 
C
C                  alpha * ||d||_infty < macheps*max(||x||_infty, 1.0d0). 
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 a problem occured in
C                  projection subroutine. Probably, we are asking for 
C                  too much accuracy in projection;
C
C             10 = the algorithm stoped because trust-region radius 
C                  (INBETRA) became too small;
C      
C            -60 = error in QR decomposition;
C      
C            -70 = error in scaling subroutine;
C     
C            -80 = some constraints are inconsistent;
C
C            -90 = error in evalf subroutine;
C
C            -92 = error in evalg subroutine;
C 
C            -94 = error in evalh subroutine;

      subroutine genlin(n, x, l, u, m, meq, lda, A, b, epsgpen, epsgpsn,
     +     epsgzsn, maxitnfp, epsnfp, maxitngp, fmin, maxit, maxfc,
     +     udelta0, ucgmia, ucgmib, cgscre, cggpnf, cgepsi, cgepsf,
     +     epsnqmp, maxitnqmp, etaint, etaext, mininterp, maxextrap,
     +     intype, gtype, hptype, trtype, scale, scmaxcnd, scmaxal,
     +     iprint, ncomp, s, y, d, dz, ind, ind2, gp, gi, gz, srow,
     +     scol, iact, rbdind, ldabar, Abar, ldh, H, tau, wi1, wd1, wd2,
     +     wd3, wd4, wd5, wd6, wd7, lwd7, wd8, wd9, wd10, ktest, eta,
     +     delmin, lspgmi, lspgma, theta, gamma, beta, sigma1, sigma2,
     +     rhoms, mseps, msmaxit, phieps, sigms, trgamma, delini,
     +     trdelmin, trdelmax, promaxit, projeps, ceps, macheps, bignum,
     +     f, g, gpeucn2, gpsupn, nit, nef, neg, neh, ncg, nch, spgnit,
     +     spgnef, tnnit, tnnef, tnintcnt, tnexgcnt, tnexbcnt, tnstpcnt,
     +     tnintfe, tnexgfe, tnexbfe, spginit, spginef, trnit, trnef,
     +     trexgcnt, trexbcnt, trexgfe, trexbfe, inform)
            
C     SCALAR ARGUMENTS
      logical scale
      integer n, m, meq, lda, maxitnfp, maxitngp, maxit, maxfc, cgscre,
     +     maxitnqmp, mininterp, maxextrap, intype, gtype, hptype,
     +     trtype, iprint, ncomp, ldabar, ldh, lwd7, msmaxit, ktest,
     +     promaxit, nit, nef, neg, neh, ncg, nch, spgnit, spgnef,
     +     tnnit, tnnef, tnintcnt, tnexgcnt, tnexbcnt, tnstpcnt,
     +     tnintfe, tnexgfe, tnexbfe, spginit, spginef, trnit, trnef,
     +     trexgcnt, trexbcnt, trexgfe, trexbfe, inform
         
      double precision epsgpen, epsgpsn, epsgzsn, epsnfp, fmin, udelta0,
     +     ucgmia, ucgmib, cggpnf, cgepsi, cgepsf, epsnqmp, etaint,
     +     etaext, scmaxcnd, scmaxal, eta, delmin, lspgmi, lspgma,
     +     theta, gamma, beta, sigma1, sigma2, rhoms, mseps, phieps,
     +     sigms, trgamma, delini, trdelmin, trdelmax, projeps, ceps,
     +     macheps, bignum, f, gpeucn2, gpsupn

C     ARRAY ARGUMENTS      
      integer ind(n), ind2(n), iact(m), rbdind(n+m), wi1(m+n+n)
      double precision x(n), l(n), u(n), A(lda,n), b(m), s(n), y(n), 
     +     d(n), dz(n), gp(n), gi(n), gz(n), srow(m), scol(n),
     +     Abar(ldabar,m), H(ldh,n), tau(m), wd1(n), wd2(n), wd3(n),
     +     wd4(n+m), wd5(n), wd6(n), wd7(lwd7), wd8(n), wd9(n), wd10(n),
     +     g(n)      

C     LOCAL SCALARS
      character * 4 ittype
      integer nefprev, infotmp, itnfp, itngp, nind, nprint, mprint,
     +     rbdlu, rbdli, i, ii, j, jj, k, nact, nliact, index1, index2,
     +     nind2
      double precision acgeps, bestprog, bcgeps, currprog, delta,
     +     epsgpen2, fprev, gpsupnprev, gieucn2, lamspg, ometa2, ssupn,
     +     sts, sty, xeucn2, xsupn, gzsupn, rowcnd, colcnd, amax, lamms
      logical calcAx, scrow, sccol

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

C     Set some initial values:

C     counters,
      nit      = 0
      nef      = 0
      neg      = 0
      neh      = 0
      ncg      = 0
      nch      = 0

      spgnit   = 0
      spgnef   = 0
      
      tnnit    = 0
      tnnef    = 0

      tnstpcnt = 0
      tnintcnt = 0
      tnexgcnt = 0
      tnexbcnt = 0

      tnintfe  = 0
      tnexgfe  = 0
      tnexbfe  = 0

      spginit  = 0
      spginef  = 0
      
      trnit    = 0
      trnef    = 0
      
      trexgcnt = 0
      trexbcnt = 0
      
      trexgfe  = 0
      trexbfe  = 0
      
      lamms    = 0.0d0
      
C     just for printing,
      nprint   = min0(n, ncomp)
      mprint   = min0(m, ncomp)

C     for computing the matrix-vector product,
c      if (gtype .eq. 1) then
c         hptype = 9
c      end if

C     for testing convergence,
      epsgpen2 = epsgpen**2

C     for testing whether to abandon the current face or not,
C     (ometa2 means '(one minus eta) squared')
      ometa2   = (1.0d0 - eta)**2

C     for testing progress in f,
      fprev      = bignum
      gpsupnprev = bignum
      bestprog   =  0.0d0
      itnfp      =      0
      itngp      =      0

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

C     for scaling.
      scrow  = .false.
      sccol  = .false.

C     Print problem information
      
      if(iprint .ge. 2) then
         write(*, 973) n
         write(*, 974) m
         write(*, 975) mprint
         do i = 1, mprint
            write(*, 976) nprint, (A(i,j), j = 1, nprint)
         end do
         write(*, 977) mprint, (b(i), i = 1, mprint)
         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) m
         write(10,975) mprint
         do i = 1, mprint
            write(10,976) nprint, (A(i,j), j = 1, nprint)
         end do
         write(10,977) mprint, (b(i), i = 1, mprint)
         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     Scale matrix A.

      if (scale) then
         call DGEEQU(m, n, A, lda, srow, scol, rowcnd, colcnd, amax, 
     +        inform)
         
         if (inform .lt. 0) then
            inform = -70
            
            if (iprint .ge. 2) then
               write(*, 1002) inform
               write(10,1002) inform
            end if
                        
            return
         end if

C        Decide if rows or columns (or either or neither of them)
C        of A should be scaled.

         if (inform .eq. 0) then
            scrow = .true.
            sccol = .true.
         else
            if (inform .gt. m) then
               scrow = .true.
               sccol = .false.
            else
               scrow = .false.
               sccol = .false.
            end if
         end if
      
         if ((amax .ge. -scmaxal) .or. (amax .le. scmaxal)) then
            if (scrow .and. (rowcnd .ge. scmaxcnd)) then
               scrow = .false.
            end if
            
            if (sccol .and. (colcnd .ge. scmaxcnd)) then
               sccol = .false.
            end if
         end if

C        If rows are scaled, vector b are also be scaled.
C        If columns are scaled, bounds and variables are also scaled.

         if (scrow .and. sccol) then
            do i = 1, m
               if (srow(i) .lt. 0.0d0) then
                  srow(i) = abs(srow(i))
               end if
               srow(i) = max(srow(i), macheps * 1.0d6)
            end do
            
            do j = 1, n
               if (scol(j) .lt. 0.0d0) then
                  scol(j) = abs(scol(j))
               end if
               scol(j) = max(scol(j), macheps * 1.0d6)
            end do

            do j = 1, n
               do i = 1, m
                  A(i,j) = A(i,j) * srow(i) * scol(j)
               end do
            end do

            do i = 1, m
               b(i) = b(i) * srow(i)
            end do

            do j = 1, n
               l(j) = l(j) / scol(j)
            end do

            do j = 1, n
               u(j) = u(j) / scol(j)
            end do

            do j = 1, n
               x(j) = x(j) / scol(j)
            end do
            
         else if (scrow) then
            do i = 1, m
               if (srow(i) .lt. 0.0d0) then
                  srow(i) = abs(srow(i))
               end if
               srow(i) = max(srow(i), macheps * 1.0d6)
            end do

            do j = 1, n
               do i = 1, m
                  A(i,j) = A(i,j) * srow(i)
               end do
            end do

            do i = 1, m
               b(i) = b(i) * srow(i)
            end do
            
         else if (sccol) then
            do j = 1, n
               if (scol(j) .lt. 0.0d0) then
                  scol(j) = abs(scol(j))
               end if
               scol(j) = max(scol(j), macheps * 1.0d6)
            end do

            do j = 1, n
               do i = 1, m
                  A(i,j) = A(i,j) * scol(j)
               end do
            end do

            do j = 1, n
               l(j) = l(j) / scol(j)
            end do
            
            do j = 1, n
               u(j) = u(j) / scol(j)
            end do

             do j = 1, n
               x(j) = x(j) / scol(j)
            end do
         end if
      end if

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

      call project(n, x, l, u, m, meq, lda, A, b, promaxit, projeps, 
     +     wi1, wd1, wd7, lwd7, inform)

      if (inform .ne. 0) then

C        Check if the solution is feasible.
         
         do i = 1, n
            if (x(i) .lt. l(i) - macheps * max(abs(l(i)), 1.0d6)) then
               go to 10
            end if
            
            if (x(i) .gt. u(i) + macheps * max(abs(u(i)), 1.0d6)) then
               go to 10
            end if
         end do
         
         do i = 1, m
            wd7(i) = 0.0d0
         end do
         
         do j = 1, n
            do i = 1, m
               wd7(i) = wd7(i) + A(i,j) * x(j)
            end do
         end do

         calcAx = .false.
         
         do i = 1, meq
            if (abs(wd7(i) - b(i)) .gt. ceps) then
               go to 10
            end if
         end do
         
         do i = meq+1, m
            if (b(i) - wd7(i) .gt. ceps) then
               go to 10
            end if
         end do

         go to 20
         
 10      if (inform .lt. 0) then
            if (iprint .ge. 2) then
               write(*, 1001) -80, -inform
               write(10,1001) -80, -inform
            end if
            
            inform = -80
         else
            if (iprint .ge. 2) then
               inform = 9
               
               write(*, 999) inform
               write(10,999) inform
            end if
         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).
           
 20   do i = 1, n
         if (x(i) .le. l(i) + macheps * max(abs(l(i)), 1.0d6)) then
            x(i) = l(i)
         else
            if (x(i) .ge. u(i) - macheps * max(abs(u(i)), 1.0d6)) then
               x(i) = u(i)
            end if
         end if
      end do
      
C     Calculate wd7 = A x.
      
      if (calcAx) then
         do i = 1, m
            wd7(i) = 0.0d0
         end do
         
         do j = 1, n
            do i = 1, m
               wd7(i) = wd7(i) + A(i,j) * x(j)
            end do
         end do
      end if

C     Check if point x is feasible.

      do i = 1, meq
         if (abs(wd7(i) - b(i)) .gt. ceps) then
            inform = 5

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

            return
         end if
      end do
      
      do i = meq+1, m
         if (b(i) - wd7(i) .gt. ceps) then
            inform = 5

            if (iprint .ge. 2) then
               write(*, 995) inform, i
               write(10,995) 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, meq
         iact(i) = i
      end do

      nact = meq
      k = m
      
      do i = meq+1, m
         if (wd7(i) .le. b(i) + macheps * max(abs(b(i)), 1.0d6)) 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 initial trust-region radius

      if (intype .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
         delta = max(trdelmin, delini * max(1.0d0, sqrt(xeucn2)))
      endif
      
C     Compute function and gradient at the initial point

      if (sccol) then
         do i = 1, n
            wd1(i) = scol(i) * x(i)
         end do
         call evalfb(n, wd1, f, inform)
      else
         call evalfb(n, x, f, inform)
      end if
      nef = nef + 1
      
      if (inform .lt. 0) then
         if (iprint .ge. 2) then
            write(*, 1000) inform
            write(10,1000) inform
         end if
         
         return
      end if

      if (gtype .eq. 0) then
         if (sccol) then
            call evalgb(n, wd1, g, inform)
            do i = 1, n
               g(i) = g(i) * scol(i)
            end do
         else
            call evalgb(n, x, g, inform)
         end if

c---  >
         do i = 1, n
            if (.not. ((g(i) .ge. -1.0d+99) .or.
     +           (g(i) .le. 1.0d+99))) then
               inform = -99
            end if
         end do
c---  >         
      
      else
         if (sccol) then
            call evalgdiff(n, wd1, g, macheps, inform)
            do i = 1, n
               g(i) = g(i) * scol(i)
            end do
         else
            call evalgdiff(n, x, g, macheps, inform)
         end if
      end if
      neg = neg + 1
      
      if (inform .lt. 0) then
         if (iprint .ge. 2) then
            write(*, 1000) inform
            write(10,1000) inform
         end if
         
         return
      end if

C     Compute continuous-project-gradient gp = P(x - g) - x.

      do i = 1, n
         gp(i) = x(i) - g(i)
      end do
      
      call project(n, gp, l, u, m, meq, lda, A, b, promaxit, projeps, 
     +     wi1, wd1, wd7, lwd7, inform)

      if (inform .ne. 0) then

C        Check if the solution is feasible.
         
         do i = 1, n
            if (gp(i) .lt. l(i) - macheps * max(abs(l(i)), 1.0d6)) then
               go to 30
            end if

            if (gp(i) .gt. u(i) + macheps * max(abs(u(i)), 1.0d6)) then
               go to 30
            end if
         end do
         
         do i = 1, m
            wd7(i) = 0.0d0
         end do
         
         do j = 1, n
            do i = 1, m
               wd7(i) = wd7(i) + A(i,j) * gp(j)
            end do
         end do
         
         do i = 1, meq
            if (abs(wd7(i) - b(i)) .gt. ceps) then
               go to 30
            end if
         end do
         
         do i = meq+1, m
            if (b(i) - wd7(i) .gt. ceps) then
               go to 30
            end if
         end do

         go to 40
         
 30      do i = 1, n
            gp(i) = x(i) - g(i)
         end do
         
         call project(n, gp, l, u, m, meq, lda, A, b, promaxit,
     +        sqrt(projeps), wi1, wd1, wd7, lwd7, inform)

         if (inform .ne. 0) then
            inform = 9
            
            if (iprint .ge. 2) then
               write(*, 999) inform
               write(10,999) inform
            end if
            
            return
         end if
      end if      

 40   do i = 1, n
         gp(i) = gp(i) - x(i)
      end do

C     Compute continuous-project-gradient Euclidian and Sup norms.

      gpsupn  = 0.0d0
      gpeucn2 = 0.0d0

      do i = 1, n
         gpsupn  = max(gpsupn, abs(gp(i)))
         gpeucn2 = gpeucn2 + gp(i)**2
      end do

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, wd7, lwd7,
     +        inform)

         if (inform .ne. 0) then
            inform = -60
            
            if (iprint .ge. 2) then
               write(*, 1004) inform
               write(10,1004) 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 * 1.0d6) then
            nliact = nliact + 1
            if (nliact .le. k) then
               go to 1
            end if
         end if
         nliact = nliact - 1
         
C        Compute internal gradient gi = Z^T gp. In fact,
C        gi = Z (Z^T Z) ^{-1} Z^T gp. But, since Z has orthogonal 
C        columns and we are interested only in the Euclidian norm of 
C        gi, it's enough to calculate Z^T gp.

         do i = 1, nind
            ii = ind(i)
            wd1(i) = gp(ii)
         end do
         
         call multZT(nind, nliact, ldabar, Abar, tau, wd1, wd2, gi,
     +        macheps)
         
C     If there is no active linear constraint, nliact = 0 and 
C     the internal gradient is the continuous-projected-gradient 
C     restricted to the space of free variables.
      
      else
         nliact = 0

         do i = 1, nind
            ii = ind(i)
            gi(i) = gp(ii)
         end do
      end if

C     Compute internal gradient Euclidian norm.
      
      gieucn2 = 0.0d0
      do i = 1, nind-nliact
         gieucn2 = gieucn2 + gi(i)**2
      end do

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     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     Print initial information

      if (iprint .ge. 2) then
         write(*, 981) nit
         write(*, 985) nprint,  (x(i), i = 1, nprint)
         write(*, 986) nprint,  (g(i), i = 1, nprint)
         write(*, 987) nprint, (gp(i), i = 1, nprint)
         write(*, 988) min0(nprint, nind2), nind2, (ind(ind2(i)), i = 1,
     +        min0(nprint, nind2))
         write(*, 989) min0(mprint, nact), nact, (iact(i), i = 1,
     +        min0(mprint, nact))
         write(*, 1005) f, sqrt(gpeucn2), sqrt(gieucn2), gpsupn, nind2, 
     +        n, nact, m, spgnit, tnnit, nef, neg, nch, ncg

         write(10,981) nit
         write(10,985) nprint,  (x(i), i = 1, nprint)
         write(10,986) nprint,  (g(i), i = 1, nprint)
         write(10,987) nprint, (gp(i), i = 1, nprint)         
         write(10,988) min0(nprint, nind2), nind2, (ind(ind2(i)), i = 1,
     +        min0(nprint, nind2))
         write(10,989) min0(mprint, nact), nact, (iact(i), i = 1,
     +        min0(mprint, nact))
         write(10,1005) f, sqrt(gpeucn2), sqrt(gieucn2), gpsupn, nind2, 
     +        n, nact, m, spgnit, tnnit, nef, neg, nch, ncg
      end if

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

 100  continue
      
C     ==================================================================
C     Test stopping criteria
C     ==================================================================

C     Test whether the continuous-projected-gradient Euclidian norm
C     is small enough to declare convergence
      
      if (gpeucn2 .le. epsgpen2) then
         inform = 0
         
         if (iprint .ge. 2) then
            write(*, 990) inform, epsgpen
            write(10,990) inform, epsgpen
         end if
         
         go to 500
      end if
      
C     Test whether the continuous-projected-gradient Sup norm
C     is small enough to declare convergence
      
      if (gpsupn .le. epsgpsn) then
         inform = 1
         
         if (iprint .ge. 2) then
            write(*, 991) inform, epsgpsn
            write(10,991) inform, epsgpsn
         end if
         
         go to 500
      end if
      
C     Test whether we performed many iterations without good progress
C     of the functional value

      if (nit .ge. 1) then
         currprog = fprev - f
         bestprog = max(currprog, bestprog)

         if (currprog .le. epsnfp * bestprog) then
            itnfp = itnfp + 1

            if (itnfp .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
            
         else
            itnfp = 0
         end if
      end if
      
C     Test whether we have performed many iterations without good 
C     reduction of the euclidian-norm of the projected gradient

      if (gpsupn .ge. gpsupnprev) then
         
         itngp = itngp + 1
         
         if (itngp .ge. maxitngp) then
            inform = 3
            
            if (iprint .ge. 2) then
               write(*, 993) inform, maxitngp
               write(10,993) inform, maxitngp
            end if
            
            go to 500
         end if
         
      else
         itngp = 0
      end if
            
C     Test whether the number of iterations is exhausted

      if (nit .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     ==================================================================
C     The stopping criteria were not satisfied, a new iteration will be 
C     made
C     ==================================================================

      nit = nit + 1

C     ==================================================================
C     Save current values, f, x and g
C     ==================================================================
      
      fprev      = f
      gpsupnprev = gpsupn
      
      do i = 1, n
         s(i) = x(i)
         y(i) = g(i)
      end do

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

C     We abandon the current face if the norm of the internal gradient
C     is smaller than (1-eta) times the norm of the continuous 
C     projected gradient. Using eta=0.9 is a rather conservative 
C     strategy in the sense that internal iterations are preferred over 
C     SPG iterations. Replace eta = 0.9 by other tolerance in (0,1) if 
C     you find it convenient. 
      
      if ((mod(nit-1,ktest) .eq. 0) .and.
     +     (gieucn2 .le. ometa2 * gpeucn2)) then

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

         ittype  = 'SPG '
         spgnit = spgnit + 1
         
C        Compute spectral steplength

         if ((nit .eq. 1) .or. (sty .le. 0.0d0)) then
            lamspg = max(1.0d0, sqrt(xeucn2)) / sqrt(gpeucn2)
         else
            lamspg = sts / sty
         end if
         lamspg = min(lspgma, max(lspgmi, lamspg))
          
C        Perform a line search with safeguarded quadratic interpolation 
C        along the direction of the spectral continuous projected 
C        gradient
          
         nefprev = nef

         call spgls(n, n, ind, n, ind, x, f, g, l, u, m, meq, nact,
     +        iact, lda, A, b, sccol, scol, .false., lamspg, etaint,
     +        mininterp, fmin, maxfc, iprint, wd1, wd2, gamma, sigma1,
     +        sigma2, promaxit, projeps, ceps, macheps, wi1, wd3, wd7,
     +        lwd7, wd4, nef, inform)

         spgnef = spgnef + (nef - nefprev) 

         if (inform .eq. 9) then
            if (iprint .ge. 2) then
               write(*, 999) inform
               write(10,999) inform
            end if

            return
         end if
         
         if (inform .lt. 0) then
            if (iprint .ge. 2) then
               write(*, 1000) inform
               write(10,1000) inform
            end if
            
            return
         end if
         
C        Compute the gradient at the new iterate

         infotmp = inform
         
         if (gtype .eq. 0) then
            if (sccol) then
               do i = 1, n
                  wd1(i) = x(i) * scol(i)
               end do
               
               call evalgb(n, wd1, g, inform)
               
               do i = 1, n
                  g(i) = g(i) * scol(i)
               end do
            else
               call evalgb(n, x, g, inform)
            end if
c---  >
            do i = 1, n
               if (.not. ((g(i) .ge. -1.0d+99) .or.
     +              (g(i) .le. 1.0d+99))) then
                  inform = -99
               end if
            end do
c---  >
         else
            if (sccol) then
               do i = 1, n
                  wd1(i) = x(i) * scol(i)
               end do
               
               call evalgdiff(n, wd1, g, macheps, inform)

               do i = 1, n
                  g(i) = g(i) * scol(i)
               end do
            else
               call evalgdiff(n, x, g, macheps, inform)
            end if
         end if
         neg = neg + 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
         
         if (inform .eq. 8) then
            if (iprint .ge. 2) then
               write(*, 998) inform, maxfc
               write(10,998) inform, maxfc
            end if
            
            return
         end if
      else
          
C        ==============================================================
C        The new iterate will belong to the closure of the current face
C        ==============================================================

C        Shrink gradient
         
         call shrink(n, nind, ind, 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 algorithm decided to stay in the current face, but there
C        is nothing to be done in it. So, a SPG iteration is forced.
         
         if (gzsupn .lt. epsgzsn) then
            
C           Compute continuous-project-gradient gp = P(x - g) - x.

            if (mod(nit-1, ktest) .ne. 0) then
               do i = 1, n
                  gp(i) = x(i) - g(i)
               end do
               
               infotmp = inform
               
               call project(n, gp, l, u, m, meq, lda, A, b, promaxit,
     +              projeps, wi1, wd1, wd7, lwd7, inform)
               
               if (inform .ne. 0) then
                  
C              Check if the solution is feasible.
                  
                  do i = 1, n
                     if (gp(i) .lt.
     +                    l(i) - macheps * max(abs(l(i)), 1.0d6)) then
                        go to 51
                     end if
                     
                     if (gp(i) .gt.
     +                    u(i) + macheps * max(abs(u(i)), 1.0d6)) then
                        go to 51
                     end if
                  end do
                  
                  do i = 1, m
                     wd7(i) = 0.0d0
                  end do
                  
                  do j = 1, n
                     do i = 1, m
                        wd7(i) = wd7(i) + A(i,j) * gp(j)
                     end do
                  end do
                  
                  do i = 1, meq
                     if (abs(wd7(i) - b(i)) .gt. ceps) then
                        go to 51
                     end if
                  end do
            
                  do i = meq+1, m
                     if (b(i) - wd7(i) .gt. ceps) then
                        go to 51
                     end if
                  end do
                  
                  go to 61
                  
 51               do i = 1, n
                     gp(i) = x(i) - g(i)
                  end do
                  
                  call project(n, gp, l, u, m, meq, lda, A, b, promaxit,
     +                 sqrt(projeps), wi1, wd1, wd7, lwd7, inform)
                  
                  if (inform .ne. 0) then
                     inform = 9
                     
                     if (iprint .ge. 2) then
                        write(*, 999) inform
                        write(10,999) inform
                     end if
                     
                     return
                  end if
               end if      
               
               inform = infotmp
               
 61            do i = 1, n
                  gp(i) = gp(i) - x(i)
               end do
               
C              Compute continuous-project-gradient Euclidian and Sup 
C              norms.
               
               gpsupn  = 0.0d0
               gpeucn2 = 0.0d0
               
               do i = 1, n
                  gpsupn  = max(gpsupn, abs(gp(i)))
                  gpeucn2 = gpeucn2 + gp(i)**2
               end do
               
C              Test whether the continuous-projected-gradient Euclidian
C              norm is small enough to declare convergence
      
               if (gpeucn2 .le. epsgpen2) then
                  inform = 0
                  
                  if (iprint .ge. 2) then
                     write(*, 990) inform, epsgpen
                     write(10,990) inform, epsgpen
                  end if
                  
                  go to 500
               end if
               
C              Test whether the continuous-projected-gradient Sup norm
C              is small enough to declare convergence
      
               if (gpsupn .le. epsgpsn) then
                  inform = 1
                  
                  if (iprint .ge. 2) then
                     write(*, 991) inform,epsgpsn
                     write(10,991) inform,epsgpsn
                  end if
                  
                  go to 500
               end if               
                          
            end if

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

               write(10,*)  
               write(10,*)  
     +            '   The current point is a minimizer of the',
     +            '   current face. A SPG iteration will be forced now.'
            end if
            
            ittype  = 'SPG '
            spgnit = spgnit + 1

C           Expand gradient

            call expand(n, nind, ind, g)
            
C           Compute spectral steplength

            if ((nit .eq. 1) .or. (sty .le. 0.0d0)) then
               lamspg = max(1.0d0, sqrt(xeucn2)) / sqrt(gpeucn2)
            else
               lamspg = sts / sty
            end if
            lamspg = min(lspgma, max(lspgmi, lamspg))

C           Perform a line search with safeguarded quadratic 
C           interpolation along the direction of the spectral 
C           continuous projected gradient

            nefprev = nef

            call spgls(n, n, ind, n, ind, x, f, g, l, u, m, meq, nact,
     +           iact, lda, A, b, sccol, scol, .false., lamspg, etaint,
     +           mininterp, fmin, maxfc, iprint, wd1, wd2, gamma,
     +           sigma1, sigma2, promaxit, projeps, ceps, macheps, wi1,
     +           wd3, wd7, lwd7, wd4, nef, inform)
            
            spgnef = spgnef + (nef - nefprev)

            if (inform .eq. 9) then
               if (iprint .ge. 2) then
                  write(*, 999) inform
                  write(10,999) inform
               end if
               
               return
            end if
            
            if (inform .lt. 0) then
               if (iprint .ge. 2) then
                  write(*, 1000) inform
                  write(10,1000) inform
               end if
               
               return
            end if
             
C           Compute the gradient at the new iterate
             
            infotmp = inform

            if (gtype .eq. 0) then
               if (sccol) then
                  do i = 1, n
                     wd1(i) = x(i) * scol(i)
                  end do
                  
                  call evalgb(n, wd1, g, inform)
                  
                  do i = 1, n
                     g(i) = g(i) * scol(i)
                  end do
               else
                  call evalgb(n, x, g, inform)
               end if

c---  >
               do i = 1, n
                  if (.not. ((g(i) .ge. -1.0d+99) .or.
     +                 (g(i) .le. 1.0d+99))) then
                     inform = -99
                  end if
               end do
c---  >               
            else
               if (sccol) then
                  do i = 1, n
                     wd1(i) = x(i) * scol(i)
                  end do
                  
                  call evalgdiff(n, wd1, g, macheps, inform)
                  
                  do i = 1, n
                     g(i) = g(i) * scol(i)
                  end do
               else
                  call evalgdiff(n, x, g, macheps, inform)
               end if
            end if
            neg = neg + 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

            if (inform .eq. 8) then
               if (iprint .ge. 2) then
                  write(*, 998) inform, maxfc
                  write(10,998) inform, maxfc
               end if
               
               return
            end if
            
            go to 200            
         end if
         
C        Shrink the point and the bounds         

         call shrink(n, nind, ind, x)
         call shrink(n, nind, ind, l)
         call shrink(n, nind, ind, u)
         
C        Call inner algorithm

         if (intype .eq. 1) then
            ittype = 'TN  '
            tnnit = tnnit + 1         
         
            call ingencan(nind, ind, nind2, ind2, n, x, f, g, gz, l, u,
     +           m, meq, nliact, nact, iact, lda, A, b, ldh, H, ldabar,
     +           Abar, tau, sccol, scol, epsnqmp, maxitnqmp, gtype,
     +           hptype, trtype, iprint, ncomp, wi1, wd1, wd2, wd3, wd5,
     +           wd4, wd6, wd7, lwd7, wd8, wd9, wd10, dz, d, delta,
     +           delmin, ssupn, sts, nit, ucgmia, ucgmib, cgscre,
     +           cgepsi, cgepsf, acgeps, bcgeps, gpeucn2, gpsupn, theta,
     +           etaint, etaext, mininterp, maxextrap, fmin, maxfc,
     +           gamma, beta, sigma1, sigma2, promaxit, projeps, ceps,
     +           macheps, bignum, ncg, nef, neg, neh, tnintcnt,
     +           tnexgcnt, tnexbcnt, tnintfe, tnexgfe, tnexbfe,
     +           tnstpcnt, tnnef, rbdlu, rbdli, rbdind, inform)
         
         else

            call inbetra(n, nind, ind, nind2, ind2, x, l, u, m, meq,
     +           nliact, nact, iact, lda, A, b, ldabar, Abar, tau,
     +           sccol, scol, f, g, gz, gzsupn, gtype, delta, lamms,
     +           rhoms, mseps, msmaxit, phieps, sigms, etaext,
     +           maxextrap, beta, trgamma, trdelmin, trdelmax, epsgpsn,
     +           gamma, lspgmi, lspgma, sigma1, sigma2, etaint,
     +           mininterp, fmin, promaxit, projeps, ceps, macheps, nit,
     +           iprint, xeucn2, gpeucn2, sts, sty, maxfc, ldh, H, wd1,
     +           dz, d, wd2, wi1, wd3, wd5, wd6, wd7, lwd7, wd4, rbdlu,
     +           rbdli, rbdind, nef, neg, neh, nch, spginit, spginef,
     +           trnit, trnef, trexgcnt, trexbcnt, trexgfe, trexbfe,
     +           ittype, inform)

         end if
         
C        Expand the point, its gradient and the bounds
            
         call expand(n, nind, ind, x)
         call expand(n, nind, ind, g)
         call expand(n, nind, ind, l)
         call expand(n, nind, ind, u)

         if (inform .lt. 0) then
            if (iprint .ge. 2) then
               write(*, 1000) inform
               write(10,1000) inform
            end if
            
            return
         end if
         
C        If the INBETRA stops declaring "first-order stationary 
C        point close to the boundary" (inform = 1) or "second-order 
C        stationary point" (inform = 2) then the main algorithm also 
C        stops when the projected gradient is null. When its not null,
C        a SPG iteration is forced.

         if ((intype .ne. 1) .and.
     +        ((inform .eq. 1) .or. (inform .eq. 2))) then
            
            if (gpsupn .le. epsgpsn) then
               
               inform = 1
               
               if (iprint .ge. 2) then
                  write(*, 991) inform, epsgpsn
                  write(10,991) inform, epsgpsn
               end if
               
               go to 500
            else
               if (iprint .ge. 2) then
                  write(*, *)  
                  write(*, *)  
     +            '     The current point is stationary in the current',
     +            '     face. A SPG iteration will be forced now.   '
                  
                  write(10,*)  
                  write(10,*)  
     +            '     The current point is stationary in the current',
     +            '     face. A SPG iteration will be forced now.   '
               end if 

               go to 300
            end if
         end if
         
C        If the line search (interpolation) in the Truncated Newton
C        direction or in the inner SPG direction stopped due to a very
C        small step (inform = 6); or if the sup-norm of the search
C        direction was too small and maximum step length was not taken,
C        (inform = 10); of if Trust-region algorithm stoped because the
C        trust-region radius became too small (inform = 5); or if a
C        problem occured in projection subroutine in an iSPG iteration
C        (inform = 9), we will discard this iteration and force a SPG
C        iteration

         if (inform .eq. 5) then
            if (iprint .ge. 2) then
               write(*, *)  
               write(*, *)  
     +            '     The previous TR iteration was discarded due to',
     +            '     a termination for very small trust-region ',
     +            '     radius. A SPG iteration will be forced now.   '
                  
               write(10,*)  
               write(10,*)  
     +            '     The previous TR iteration was discarded due to',
     +            '     a termination for very small trust-region ',
     +            '     radius. A SPG iteration will be forced now.   '
            end if
            
            delta = max(trdelmin, delini * max(1.0d0, sqrt(xeucn2)))
            delta = min(delta, trdelmax)
            
            go to 300
               
         else if (inform .eq. 6) then
            if (iprint .ge. 2) then
               write(*, *)  
               write(*, *)  
     +  '     The previous ', ittype, ' iteration was discarded due to',
     +            '     a termination for very small step in the line ',
     +            '     search. A SPG iteration will be forced now.   '
                  
               write(10,*)  
               write(10,*)  
     +  '     The previous ', ittype, ' iteration was discarded due to',
     +            '     a termination for very small step in the line ',
     +            '     search. A SPG iteration will be forced now.   '
            end if
            go to 300

         else if (inform .eq. 9) then
            if (iprint .ge. 2) then
               write(*, *)  
               write(*, *)  
     +          '     The previous iSPG iteration was discarded due to',
     +          '     a problem in projection subroutine. A SPG ',
     +          '     iteration will be forced now.   '
                  
               write(10,*)  
               write(10,*)  
     +          '     The previous iSPG iteration was discarded due to',
     +          '     a problem in projection subroutine. A SPG ',
     +          '     iteration will be forced now.   '
            end if
            go to 300
            
         else if (inform .eq. 10) then
            if (iprint .ge. 2) then
               write(*, *)  
               write(*, *)  
     +     '  The previous ', ittype, ' iteration was discarded due to',
     +            '  a very small step length and no change in active ',
     +            '  set. A SPG iteration will be forced now.   '
                  
               write(10,*)  
               write(10,*)  
     +     '  The previous ', ittype, ' iteration was discarded due to',
     +            '  a very small step length and no change in active ',
     +            '  set. A SPG iteration will be forced now.   '
            end if             
            go to 300
         end if

         go to 200
         
 300     ittype  = 'SPG '
         spgnit = spgnit + 1
             
C        Compute spectral steplength

         if ((nit .eq. 1) .or. (sty .le. 0.0d0)) then
            lamspg = max(1.0d0, sqrt(xeucn2)) / sqrt(gpeucn2)
         else
            lamspg = sts / sty
         end if
         lamspg = min(lspgma, max(lspgmi, lamspg))
         
C        Perform a line search with safeguarded quadratic 
C        interpolation along the direction of the spectral 
C        continuous projected gradient

         nefprev = nef
            
C        write(*,*) 'ANTES'
C        write(*,*) nind,(ind(i),i=1,nind)
         call spgls(n, n, ind, n, ind, x, f, g, l, u, m, meq, nact,
     +        iact, lda, A, b, sccol, scol, .false., lamspg, etaint,
     +        mininterp, fmin, maxfc, iprint, wd1, wd2, gamma, sigma1,
     +        sigma2, promaxit, projeps, ceps, macheps, wi1, wd3, wd7,
     +        lwd7, wd4, nef, inform)
C        write(*,*) 'DEPOIS'
    
         spgnef = spgnef + (nef - nefprev)
            
         if (inform .eq. 9) then
            if (iprint .ge. 2) then
               write(*, 999) inform
               write(10,999) inform
            end if
            
            return
         end if
         
         if (inform .lt. 0) then
            if (iprint .ge. 2) then
               write(*, 1000) inform
               write(10,1000) inform
            end if
            
            return
         end if
             
C        Compute the gradient at the new iterate
             
         infotmp = inform
            
         if (gtype .eq. 0) then
            if (sccol) then
               do i = 1, n
                  wd1(i) = x(i) * scol(i)
               end do
               
               call evalgb(n, wd1, g, inform)
               
               do i = 1, n
                  g(i) = g(i) * scol(i)
               end do
            else
               call evalgb(n, x, g, inform)
            end if

c---  >
            do i = 1, n
               if (.not. ((g(i) .ge. -1.0d+99) .or.
     +              (g(i) .le. 1.0d+99))) then
                  inform = -99
               end if
            end do
c---  >            
         else
            if (sccol) then
               do i = 1, n
                  wd1(i) = x(i) * scol(i)
               end do
               
               call evalgdiff(n, wd1, g, macheps, inform)
               
               do i = 1, n
                  g(i) = g(i) * scol(i)
               end do
            else
               call evalgdiff(n, x, g, macheps, inform)
            end if
         end if
         neg = neg + 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
         
         if (inform .eq. 8) then
            if (iprint .ge. 2) then
               write(*, 998) inform, maxfc
               write(10,998) inform, maxfc
            end if
            
            return
         end if
         
      end if
            
C     ==================================================================
C     Prepare for the next iteration 
C     ==================================================================

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).

 200  do i = 1, n
         if (x(i) .le. l(i) + macheps * max(abs(l(i)), 1.0d6)) then
            x(i) = l(i)
         else
            if (x(i) .ge. u(i) - macheps * max(abs(u(i)), 1.0d6)) then
               x(i) = u(i)
            end if
         end if
      end do
      
C     Calculate wd7 = A x.

      do i = 1, m
         wd7(i) = 0.0d0
      end do
      
      do j = 1, n
         do i = 1, m
            wd7(i) = wd7(i) + A(i,j) * x(j)
         end do
      end do
      
C     Check if point x is feasible.
      
      do i = 1, meq
         if (abs(wd7(i) - b(i)) .gt. ceps) then
            inform = 5

            if (iprint .ge. 2) then
               write(*, 995) inform, i
               write(10,995) inform, i
            end if
            
            return
         end if
      end do
      
      do i = meq+1, m
         if (b(i) - wd7(i) .gt. ceps) then
            inform = 5
            
            if (iprint .ge. 2) then
               write(*, 995) inform, i
               write(10,995) inform, i
            end if
            
            return
         end if
      end do
      
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
      do i = 1, n
         s(i) = x(i) - s(i)
         y(i) = g(i) - y(i)
         sts  = sts + s(i)**2
         sty  = sty + s(i) * y(i)
         ssupn = max(ssupn, abs(s(i)))
      end do

C     If maximum step length was used, update list of free variables
C     and list of active linear constraints.

      if (inform .eq. 11) then
         
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
                  wd1(i) = 0.0d0
               end do
               
               index1 = rbdind(k)
               if (index1 .gt. n) then
                  wd1(index1-n) = -1.0d0
               else
                  wd1(index1) = 1.0d0
               end if

               call updateQR(nind, nliact, ldabar, Abar, tau, wd1, wd2,
     +              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, wd7,
     +              lwd7, inform)

               if (inform .ne. 0) then
                  inform = -60
                  
                  if (iprint .ge. 2) then
                     write(*, 1004) inform
                     write(10,1004) 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 * 1.0d6) 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)
                     wd1(i) = A(index1,ii)
                  end do
                  
                  call updateQR(nind, nliact, ldabar, Abar, tau, wd1, 
     +                 wd2, macheps)
               end do
            
            end if
         end if

      else if ((ittype .eq. 'SPG ') .or. (inform .eq. 4) .or.
     +        (inform .eq. 8)) then
         
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 = meq
         k = m
         
         do i = meq+1, m
            if (wd7(i) .le. b(i) + macheps * max(abs(b(i)), 1.0d6)) 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, wd7, lwd7,
     +           inform)

            if (inform .ne. 0) then
               inform = -60
               
               if (iprint .ge. 2) then
                  write(*, 1004) inform
                  write(10,1004) 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
 4          if (abs(Abar(nliact,nliact)) .gt. macheps * 1.0d6) then
               nliact = nliact + 1
               if (nliact .le. k) then
                  go to 4
               end if
            end if
            nliact = nliact - 1
         end if
      end if

C     Compute continuous-project-gradient gp = P(x - g) - x.

 90   if (mod(nit, ktest) .eq. 0) then
         do i = 1, n
            gp(i) = x(i) - g(i)
         end do
         
         infotmp = inform
         
         call project(n, gp, l, u, m, meq, lda, A, b, promaxit, projeps,
     +        wi1, wd1, wd7, lwd7, inform)

         if (inform .ne. 0) then
         
C           Check if the solution is feasible.
         
            do i = 1, n
               if (gp(i) .lt. l(i) - macheps *max(abs(l(i)),1.0d6)) then
                  go to 50
               end if
               
               if (gp(i) .gt. u(i) + macheps *max(abs(u(i)),1.0d6)) then
                  go to 50
               end if
            end do
         
            do i = 1, m
               wd7(i) = 0.0d0
            end do
            
            do j = 1, n
               do i = 1, m
                  wd7(i) = wd7(i) + A(i,j) * gp(j)
               end do
            end do
            
            do i = 1, meq
               if (abs(wd7(i) - b(i)) .gt. ceps) then
                  go to 50
               end if
            end do
            
            do i = meq+1, m
               if (b(i) - wd7(i) .gt. ceps) then
                  go to 50
               end if
            end do
            
            go to 60
            
 50         do i = 1, n
               gp(i) = x(i) - g(i)
            end do
            
            call project(n, gp, l, u, m, meq, lda, A, b, promaxit,
     +           sqrt(projeps), wi1, wd1, wd7, lwd7, inform)
            
            if (inform .ne. 0) then
               inform = 9
               
               if (iprint .ge. 2) then
                  write(*, 999) inform
                  write(10,999) inform
               end if
               
               return
            end if
         end if      
         
         inform = infotmp
         
 60      do i = 1, n
            gp(i) = gp(i) - x(i)
         end do
         
C        Compute continuous-project-gradient Euclidian and Sup norms.
         
         gpsupn  = 0.0d0
         gpeucn2 = 0.0d0

         do i = 1, n
            gpsupn  = max(gpsupn, abs(gp(i)))
            gpeucn2 = gpeucn2 + gp(i)**2
         end do
         
C        Compute internal gradient gi = Z^T gp. In fact,
C        gi = Z (Z^T Z) ^{-1} Z^T gp. But, since Z has orthogonal 
C        columns and we are interested only in the Euclidian norm of 
C        gi, it's enough to calculate Z^T gp.
         
         if (nliact .gt. 0) then
            do i = 1, nind
               ii = ind(i)
               wd1(i) = gp(ii)
            end do
            
            call multZT(nind, nliact, ldabar, Abar, tau, wd1, wd2, gi,
     +           macheps)
            
C        If there is no active linear constraint, nliact = 0 and 
C        the internal gradient is the continuous-projected-gradient 
C        restricted to the space of free variables.
         
         else
            do i = 1, nind
               ii = ind(i)
               gi(i) = gp(ii)
            end do
         end if
         
C        Compute internal gradient Euclidian norm.
      
         gieucn2 = 0.0d0
         do i = 1, nind-nliact
            gieucn2 = gieucn2 + gi(i)**2
         end do
      end if

C     Print information of this iteration

      if (iprint .ge. 2) then 
         write(*, 983) nit, ittype
         write(*, 985) nprint,  (x(i), i = 1, nprint)
         write(*, 986) nprint,  (g(i), i = 1, nprint)
         write(*, 987) nprint, (gp(i), i = 1, nprint)
         write(*, 988) min0(nprint, nind2), nind2, (ind(ind2(i)), i = 1,
     +        min0(nprint, nind2))
         write(*, 989) min0(mprint, nact), nact, (iact(i), i = 1,
     +        min0(mprint, nact))
         write(*, 1005) f, sqrt(gpeucn2), sqrt(gieucn2), gpsupn, nind2, 
     +        n, nact, m, spgnit, tnnit, nef, neg, nch, ncg
          
         write(10,983) nit, ittype
         write(10,985) nprint,  (x(i), i = 1, nprint)
         write(10,986) nprint,  (g(i), i = 1, nprint)
         write(10,987) nprint, (gp(i), i = 1, nprint)
         write(10,988) min0(nprint, nind2), nind2, (ind(ind2(i)), i = 1,
     +        min0(nprint, nind2))
         write(10,989) min0(mprint, nact), nact, (iact(i), i = 1,
     +        min0(mprint, nact))
         write(10,1005) f, sqrt(gpeucn2), sqrt(gieucn2), gpsupn, nind2, 
     +        n, nact, m, spgnit, tnnit, nef, neg, nch, ncg
      end if
       
C     ==================================================================
C     Test some stopping criteria that may occur inside inner algorithms
C     ==================================================================

C     Test whether the functional value is very small
      
      if (inform .eq. 4) then
         
         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 functional evaluations is exhausted

      if (inform .eq. 8) then
         
         if (iprint .ge. 2) then
            write(*, 998) inform, maxfc
            write(10,998) inform, maxfc
         end if
         
         go to 500
         
      end if
            
C     If SPG stoped because step in the line search was too small
C     after having made at least mininterp interpolations, the main
C     algorithm also stops.
      
      if (inform .eq. 6) 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     Print final information

      if (iprint .ge. 2) then
         write(*, 982) nit
         write(*, 985) nprint,  (x(i), i = 1, nprint)
         write(*, 986) nprint,  (g(i), i = 1, nprint)
         write(*, 987) nprint, (gp(i), i = 1, nprint)
         write(*, 988) min0(nprint, nind2), nind2, (ind(ind2(i)), i = 1,
     +        min0(nprint, nind2))
         write(*, 989) min0(mprint, nact), nact, (iact(i), i = 1,
     +        min0(mprint, nact))
         write(*, 1005) f, sqrt(gpeucn2), sqrt(gieucn2), gpsupn, nind2,
     +        n, nact, m, spgnit, tnnit, nef, neg, nch, ncg
          
         write(10,982) nit
         write(10,985) nprint,  (x(i), i = 1, nprint)
         write(10,986) nprint,  (g(i), i = 1, nprint)
         write(10,987) nprint, (gp(i), i = 1, nprint)
         write(10,988) min0(nprint, nind2), nind2, (ind(ind2(i)), i = 1,
     +        min0(nprint, nind2))
         write(10,989) min0(mprint, nact), nact, (iact(i), i = 1,
     +        min0(mprint, nact))
         write(10,1005) f, sqrt(gpeucn2), sqrt(gieucn2), gpsupn, nind2,
     +        n, nact, m, spgnit, tnnit, nef, neg, nch, ncg
      end if
       
      return 
  
C     Non-executable statements

 973  format(/1X,'Entry to GENLIN. Number of variables: ',I7)
 974  format(/1X,'Number of linear constraints: ',I7)
 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,
     +     ' (This point was obtained using a ',A4,' iteration)')
 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 continuous 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))      
 990  format(/1X,'Flag of GENLIN = ',I3,
     +    ' (convergence with Euclidian-norm of the projected gradient',
     +    /,1X,'smaller than ',1PD11.4,')')
 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')
 993  format(/1X,'Flag of GENLIN = ',I3,
     +  ' (The algorithm stopped because the order of the',
     +  /,1X,'Euclidian-norm of the continuous projected gradient did',
     +  ' not change during ',/,1X,I7,' consecutive iterations.',
     +  ' Probably, an exaggerated small norm of the',/,1X,'continuous',
     +  ' projected gradient is required for declaring convergence')
 994  format(/1X,'Flag of GENLIN = ',I3,
     +     ' (The algorithm stopped because the functional value is',
     +     /,1X,'smaller than ',1PD11.4)
 995  format(/1X,'Flag of GENLIN = ',I3,
     +     ' (The algorithm stopped because the point is unfeasible.',
     +     /,1X,'Linear constraint ',I3,' is not satisfied') 
 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 was exceeded the maximum allowed number of iterations',
     +     /,1X,'(maxit=',I7,')')
 998  format(/1X,'Flag of GENLIN = ',I3,
     +     ' (It was exceeded the maximum allowed number of functional',
     +     /,1X,'evaluations (maxfc=',I7,')')
 999  format(/1X,'Flag of GENLIN = ',I3,
     +     ' (Problem in projection routine. Point may be unfeasible)')
 1000 format(/1X,'Flag of GENLIN = ',I3,' Fatal Error')
 1001 format(/1X,'Flag of GENLIN = ',I3,
     +     ' (Constraint ', I3, ' is inconsistent)')
 1002 format(/1X,'Flag of GENLIN = ',I3,
     +     ' (Error in scaling subroutine)')
 1004 format(/1X,'Flag of GENLIN = ',I3,
     +     ' (Error in QR decomposition)')
 1005 format(1X,'Functional value: ', 1PD11.4,
     + /,1X,'Euclidian-norm of the continuous projected gradient: ',
     + 1PD11.4,
     + /,1X,'Euclidian-norm of the internal projection of gp: ',1PD11.4,
     + /,1X,'Sup-norm of the continuous projected gradient: ',1PD11.4,
     + /,1X,'Free variables at this point: ',I7,
     + ' (over a total of ',I7,')',
     + /,1X,'Active constraints at this point: ',I7,
     + ' (over a total of ',I7,')',
     + /,1X,'SPG iterations: ',I7,
     + /,1X,'TN iterations: ',I7,
     + /,1X,'Functional evaluations: ',I7,
     + /,1X,'Gradient evaluations: ',I7,
     + /,1X,'Cholesky decompositions: ',I7,
     + /,1X,'Conjugate gradient iterations: ',I7)

      end

C     ******************************************************************
C     ******************************************************************
      
C     Safeguarded quadratic interpolation, used in the Spectral
C     Projected Gradient directions.
C
C     On Entry
C
C     n        integer
C              the order of the x
C
C     nind     integer
C              number of free variables (including the ones used to
C              update QR factorization of Abar)
C
C     ind      integer ind(nind)
C              array which contains, in the first nind positions, the
C              identifiers of the free variables
C
C     nind2    integer
C              number of really free variables
C     
C     ind2     integer ind2(nind)
C              array which contains, in the first nind2 positions, 
C              the indices of ind that contain the real free variables
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     m        integer
C              number of linear constraints
C
C     meq      integer
C              number of equality linear constraints
C     
C     nact     integer
C              number of active linear constraits
C
C     iact     integer iact(m)
C              stores the indices of linear active constraints
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(m)
C              right-hand side of linear constraints
C     
C     sccol    logical
C              true iff variables should be scaled
C
C     scol     double precision scol(n)
C              variable scaling factors
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 2. If iprint is greater than or equal to 
C              2, GENLIN 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     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, sigma*alpha] then we take
C              alpha_new = alpha / etaint
C
C              RECOMMENDED: sigma1 = 0.1 and sigma2 = 0.9
C
C     promaxit integer
C              maximum allowed number of iterations for projection
C      
C              RECOMMENDED: promaxit = 5000
C
C              CONSTRAINTS: promaxit > 0
C
C     projeps  double precision
C              error allowed in projection
C
C              RECOMMENDED: projeps = 1.0d-13
C
C              CONSTRAINTS: projeps > 0
C
C     ceps     double precision
C              error allowed to consider some point x unfeasible
C              (with respect to linear constaints)
C
C              RECOMMENDED: ceps = 1.0d-05
C
C              CONSTRAINTS: ceps > 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     wi1      integer wi1(m+n+n)
C     wd1      double precision wd1(n)
C     wd2      double precision wd2(lwd2)
C     bbar     double precision bbar(m)
C              working vectors
C
C     lwd2     integer
C              size of array wd2. Must be, at least, 1.5*n*n+10*n+m
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     nef      integer
C              number of functional evaluations used in the line search   
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                  becames 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              9 = problem in projection subroutine;
C
C            -90 = error in evalf subroutine.
      
      subroutine spgls(n, nind, ind, nind2, ind2, x, f, g, l, u, m, meq,
     +     nact, iact, lda, A, b, sccol, scol, inner, lamspg, etaint, 
     +     mininterp, fmin, maxfc, iprint, xtrial, d, gamma, sigma1,
     +     sigma2, promaxit, projeps, ceps, macheps, wi1, wd1, wd2,
     +     lwd2, bbar, nef, inform)

C     SCALAR ARGUMENTS
      logical sccol, inner
      integer n, nind, nind2, m, meq, nact, lda, mininterp, maxfc,
     +     iprint, lwd2, promaxit, nef, inform
      double precision f, lamspg, etaint, fmin, gamma, sigma1, sigma2,
     +     projeps, ceps, macheps

C     ARRAY ARGUMENTS
      integer ind(nind), ind2(nind), iact(m), wi1(m+n+n)
      double precision x(n), g(n), l(n), u(n), A(lda,n), b(m), scol(n),
     +     xtrial(n), d(n), wd1(n), wd2(lwd2), bbar(m)
 
C     LOCAL SCALARS
      logical samep
      integer i, ii, j, interp
      double precision alpha, atmp, ftrial, gtd, 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

      if (inner) then

         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 = meq+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 = meq+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 = meq+1, nact
            iact(i) = i
         end do

         do i = nact+1, m
            iact(i) = m + 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, m
            bbar(i) = b(i)
         end do
         
         do j = nind2+1, n
            do i = 1, m
               bbar(i) = bbar(i) - A(i,j) * x(j)
            end do
         end do

C        Project.

         call project(nind2, xtrial, l, u, m, nact, lda, A, bbar,
     +        promaxit, projeps, wi1, wd1, wd2, lwd2, inform)
      else

         do i = 1, m
            bbar(i) = b(i)
         end do
         
         call project(n, xtrial, l, u, m, meq, lda, A, b, promaxit,
     +        projeps, wi1, wd1, wd2, lwd2, inform)
      end if
      
      if (inform .ne. 0) then

C        Check if the solution is feasible.
         
         do i = 1, nind2
            if (xtrial(i) .lt. l(i) - macheps*max(abs(l(i)),1.0d6)) then
               go to 10
            end if

            if (xtrial(i) .gt. u(i) + macheps*max(abs(u(i)),1.0d6)) then
               go to 10
            end if
         end do
         
         do i = 1, m
            wd2(i) = 0.0d0
         end do
         
         do j = 1, nind2
            do i = 1, m
               wd2(i) = wd2(i) + A(i,j) * xtrial(j)
            end do
         end do
         
         do i = 1, meq
            if (abs(wd2(i) - bbar(i)) .gt. ceps) then
               go to 10
            end if
         end do

         do i = meq+1, m
            if (bbar(i) - wd2(i) .gt. ceps) then
               go to 10
            end if
         end do

         go to 20
                  
 10      do i = 1, nind2
            xtrial(i) = x(i) - lamspg * g(i)
         end do

         if (inner) then
            call project(nind2, xtrial, l, u, m, nact, lda, A, bbar,
     +           promaxit, sqrt(projeps), wi1, wd1, wd2, lwd2, inform)
         else
            call project(n, xtrial, l, u, m, meq, lda, A, b, promaxit, 
     +           sqrt(projeps), wi1, wd1, wd2, lwd2, inform)
         end if
         
         if (inform .ne. 0) then
            inform = 9
            
            if (iprint .ge. 3) then
               write(*, 1000) inform
               write(10,1000) inform
            end if
            
            return
         end if
      end if
      
 20   gtd = 0.0d0
      do i = 1, nind2
         d(i) = xtrial(i) - x(i)
         gtd  = gtd + g(i) * d(i)
      end do

      if (inner) then
         call expand(nind, nind2, ind2, xtrial)
         call expand(nind, nind2, ind2, x)
         
         call calcf(n, nind, ind, xtrial, x, sccol, scol, wd1, ftrial,
     +        inform)

         call shrink(nind, nind2, ind2, xtrial)
         call shrink(nind, nind2, ind2, x)
         
      else
         if (sccol) then
            do i = 1, n
               wd1(i) = scol(i) * xtrial(i)
            end do
            
            call evalfb(n, wd1, ftrial, inform)
         else
            call evalfb(n, xtrial, ftrial, inform)
         end if
      end if
      nef = nef + 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 the first trial

      if (iprint .ge. 3) then
         write(*, 982) alpha, ftrial, nef
         write(10,982) alpha, ftrial, nef
      end if

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(*, 994) inform
            write(10,994) inform
         end if
         
         go to 500
         
      end if

C     Test whether the number of functional evaluations is exhausted

      if (nef .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(*, 998) inform
            write(10,998) inform
         end if

         go to 500
         
      end if
     
C     Main loop

 100  continue

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(*, 990) inform
            write(10,990) inform
         end if
         
         go to 500
         
      end if

C     Compute new step (safeguarded quadratic interpolation)

      interp = interp + 1
      
      if (alpha .lt. sigma1) then
         alpha = alpha / etaint      
         
      else
         atmp = (- gtd * alpha**2) / 
     +        (2.0d0 * (ftrial - f - alpha * gtd))
         
         if ((atmp .lt. sigma1) .or. (atmp .gt. sigma2 * alpha)) then
            alpha = alpha / etaint
         else
            alpha = atmp
         end if
      end if
      
C     Compute new trial point

      do i = 1, nind2
         xtrial(i) = x(i) + alpha * d(i)
      end do

      if (inner) then
         call expand(nind, nind2, ind2, xtrial)
         call expand(nind, nind2, ind2, x)
         
         call calcf(n, nind, ind, xtrial, x, sccol, scol, wd1, ftrial,
     +        inform)
         
         call shrink(nind, nind2, ind2, xtrial)
         call shrink(nind, nind2, ind2, x)
         
      else
         if (sccol) then
            do i = 1, n
               wd1(i) = scol(i) * xtrial(i)
            end do
            
            call evalfb(n, wd1, ftrial, inform)
         else
            call evalfb(n, xtrial, ftrial, inform)
         end if
      end if
      nef = nef + 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 the current trial

      if (iprint .ge. 3) then
         write(*, 982) alpha, ftrial, nef
         write(10,982) alpha, ftrial, nef
      end if

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(*, 994) inform
            write(10,994) inform
         end if
         
         go to 500
         
      end if

C     Test whether the number of functional evaluations is exhausted

      if (nef .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(*, 998) inform
            write(10,998) inform
         end if

         go to 500
         
      end if
      
C     Test whether at least mininterp interpolations were made and two 
C     consecutive iterates are close enough

      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(*, 996) inform
            write(10,996) inform
         end if
         
         go to 500
      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')
 982  format(6x,'Alpha= ',1PD11.4,' F= ',1PD11.4,' FE= ',I5)
 990  format(6x,'Flag of SPG Line search = ',I3,
     +          ' (Armijo-like criterion satisfied)')
 994  format(6x,'Flag of SPG Line search = ',I3,
     +          ' (Small functional value, smaller than ',/,
     +       6X,'parameter fmin)')
 996  format(6x,'Flag of SPG Line search = ',I3,
     +          ' (Too small step in the interpolation)')
 998  format(6x,'Flag of SPG Line search = ',I3,
     +          ' (Too many functional evaluations)')
 1000 format(6X,'Flag of SPG Line search = ',I3,' Fatal Error')

      end

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

C     This subroutine finds a unconstrained minimizer of objective 
C     function inside the constraints set, hits the boundary 
C     (obtaining function decrease), or finds an interior point where 
C     the objective function has sufficient decrease (compared to its 
C     value at x). This is done using Conjugate Gradients method (like
C     GENCAN).
C
C     On Entry
C     
C     nind     integer
C              number of free variables (including the ones used to
C              update QR factorization of Abar)
C
C     ind      integer ind(nind)
C              array which contains, in the first nind positions, the
C              identifiers of the free variables
C
C     nind2    integer
C              number of really free variables
C     
C     ind2     integer ind2(nind)
C              array which contains, in the first nind2 positions, 
C              the indices of ind that contain the real free variables
C
C     n        integer
C              dimension of the full space
C
C     x        double precision x(n)
C              point inside current face
C
C              The first nind positions of x contains the free variables 
C              x_ind(1), x_ind(2), ..., x_ind(nind)
C
C     f        double precision
C              value of objective function at x
C      
C     g        double precision g(n)
C              gradient of objective function at x, It components are 
C              ordered in the same way as x
C     
C     gz       double precision gz(nind-nliact)
C              Projected gradient: Z^T g. It components are ordered
C              in the same way as x and g
C
C     l        double precision l(n)
C              lower bounds on x + s. It components are ordered in the 
C              same way as x, g and gz
C
C     u        double precision u(n)
C              upper bounds on x + s. It components are ordered in the 
C              same way as x, g, gz and l
C      
C     m        integer
C              number of linear constraints in the original problem
C
C     meq      integer
C              number of equality linear constraints in the original
C              problem
C      
C     nliact   integer
C              number of linear independent active constraints
C     
C     nact     integer
C              number of linear active constraints
C     
C     iact     integer iact(m)
C              stores the indices of linear active constraints
C      
C     lda      integer
C              leading dimension of A
C      
C     A        double precision(lda,n)
C              matrix of coeficients of the linear constraints.
C              Columns of A are ordered the same way as x, g, 
C              gz, l and u
C     
C     b        double precision(m)
C              right-hand side of the linear constraints
C     
C     ldh      integer
C              leading dimension of matrix H
C     
C     H        double precision H(ldh,n)
C              Hessian of objetive function at x
C
C     ldabar   integer
C              leading dimension of matrix Abar
C           
C     Abar     double precision Abar(ldabar,nact)
C              used to calculate base of null space spanned by active
C              linear constraints. Abar stores the QR factorization of
C              matrix A
C      
C     tau      double precision tau(nact)
C              used to calculate base of null space spanned by active
C              linear constraints
C     
C     sccol    logical
C              true iff variables should be scaled
C
C     scol     double precision scol(n)
C              variable scaling factors
C      
C
C     epsnqmp  double precision
C              See below
C
C     maxitnqmp integer
C              This and the previous one parameter are used for a 
C              stopping criterion of the conjugate gradient 
C              subalgorithm. If the progress in the quadratic model is 
C              less or equal than a fraction of the best progress 
C              ( epsnqmp * bestprog ) during maxitnqmp consecutive 
C              iterations then CG is stopped by not enough progress of 
C              the quadratic model.
C
C              RECOMMENDED: epsnqmp = 1.0d-4, maxitnqmp = 5
C
C     gtype    integer
C              gtype indicates in which way the gradient of the 
C              objective function will be computed. If the user have 
C              been implemented the user-supplied evalg subroutine to 
C              compute the gradient of the objective function then 
C              gtype argument must be set to 0 (ZERO) and the user-
C              supplied evalg subroutine will be called by GENLIN any 
C              time the gradient would be required.
C
C              RECOMMENDED: gtype = 0 (provided you have the evalg 
C                           subroutine)
C
C              CONSTRAINTS: allowed values are just 0 or 1.
C
C     hptype   integer
C              The way in which the product of the Hessian matrix
C              by a vector will be done depends on the value of the 
C              parameter hptype in the following way:
C
C              = 0, means that a subroutine provided by the user will be
C                   used to compute the Hessian-vector product.
C
C              = 1, 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              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     trtype   integer
C              type of trust-region radius
C              trtype = 0 means 2-norm trust-region
C              trtype = 1 means infinite-norm trust-region
C
C              RECOMMENDED: trtype = 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, GENLIN 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     wi1      integer wi1(n+n+m)
C     wd1      double precision wd1(n)
C     wd2      double precision wd2(n)
C     wd3      double precision wd3(n)
C     wd4      double precision wd4(n)
C     wd5      double precision wd5(n)      
C     wd6      double precision wd6(n)
C     wd7      double precision wd7(lwd7)
C     wd8      double precision wd8(n)            
C     wd9      double precision wd9(n)
C     wd10     double precision wd10(n)
C     dz       double precision dz(nind-nliact)
C     d        double precision d(n)      
C              working vectors
C
C     delta    double precision
C              trust region radius (||s||_2 <= delta) 
C    
C     ssupn    double precision
C              x_{k+1} - x_k sup-norm
C      
C     sts      double precision
C              x_{k+1} - x_k Euclidian norm
C      
C     nit      integer
C              number of current global iteration
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( nred ) ) when the method is
C              far from the solution to nred when the method is near to 
C              the solution, where nred is the number of variables of the 
C              subproblem (equal to the number of free variables minus the
C              number of LI linear constraints). 
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     cgscre   integer
C              See comments in the begining of genlin 
C     
C     cgepsi   double precision
C              See below
C
C     cgepsf   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     gpeucn2  double precision
C              squared projected gradient Euclidian norm
C      
C     gpsupn   double precision
C              projected gradient sup-norm
C      
C     delmin   double precision
C              Smaller Conjugate Gradients ''trust radius'' to compute 
C              the Truncated Newton direction
C
C              RECOMMENDED: delmin = 1.0d+04
C
C              CONSTRAINTS: delmin > 0.0
C
C     acgeps   double precision
C              see bellow
C      
C     bcgeps   double precision
C              used to compute a linear relation between gpeucn2 and
C              cgeps2, i.e., 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     
C     theta    double precision
C              constant for the angle condition, i.e., at iteration k we 
C              need a direction d_k such that <gk,dk> <= - theta 
C              ||gk||_2 ||dk||_2, where gk is \nabla f(xk)
C
C              RECOMMENDED: theta = 10^{-6}
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     etaext   double precision
C              constant for the extrapolation
C              when extrapolating we try alpha_new = alpha * etaext
C
C              RECOMMENDED: etaext = 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     maxextrap integer
C              constant to limit the number of extrapolations
C
C              RECOMMENDED: maxextrap = 1000 (a big number)
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     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     beta     double precision
C              constant for the beta condition <dk, g(xk + dk)>  <  beta 
C              * <dk,gk>. If (xk + dk) satisfies the Armijo condition 
C              but does not satisfy the beta condition then the point is 
C              accepted, but if it satisfied the Armijo condition and 
C              also satisfies the beta condition then we know that there 
C              is the possibility for a successful extrapolation
C
C              RECOMMENDED: beta = 0.5
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     promaxit integer
C              maximum allowed number of iterations for projection
C      
C              RECOMMENDED: promaxit = 5000
C
C              CONSTRAINTS: promaxit > 0
C
C     projeps  double precision
C              error allowed in projection
C
C              RECOMMENDED: projeps = 1.0d-13
C
C              CONSTRAINTS: projeps > 0
C
C     ceps     double precision
C              error allowed to consider some point x unfeasible
C              (with respect to linear constaints)
C
C              RECOMMENDED: ceps = 1.0d-05
C
C              CONSTRAINTS: ceps > 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 1.0d+99
C
C     On Return
C
C     x        double precision x(n)
C              new point. It is either a unconstrained minimizer of
C              objective function inside the constraints set, or lays
C              the boundary (obtaining function decrease), or is an
C              interior point where the objective function has 
C              sufficient decrease (compared to the initial value)
C
C     ncg      integer
C              number of Conjugated Gradients iterations
C
C     nef      integer
C              number of functional evaluations
C
C     neg      integer
C              number of gradient evaluations
C
C     neh      integer
C              number of Hessian evaluations 
C      
C     tnintcnt integer
C              number of interpolations
C
C     tnexgcnt integer
C              number of good extrapolations
C
C     tnexbcnt integer
C              number of bad extrapolations
C
C     tnintfe  integer
C              number of functional evaluations used in interpolations 
C              along Truncated-Newton directions
C
C     tnexgfe  integer
C              number of functional evaluations used in successful 
C              extrapolations along Truncated-Newton directions
C
C     tnexbfe  integer
C              number of functional evaluations used in unsuccessful 
C              extrapolations along Truncated-Newton directions
C
C     tnstpcnt integer
C              number of times the Newton point was accepted (without
C              interpolations nor extrapolations)
C
C     tnnef    integer
C              number of functional evaluations along Truncated-Newton
C              directions
C      
C     rbdlu    integer
C              number of bounds attained at x
C      
C     rbdli    integer
C              rbdli-rbdlu is the number of linear constraints
C              attained at x
C      
C     rbdind   integer rbdind(n+m)
C              indeces of variables (or linear constraints) that are
C              satisfied by equality in x
C     
C     inform   integer
C              termination parameter:
C
C              0 = convergence with an Armijo-like criterion
C                  (f(xnew) <= f(x) + 1.0d-4 * alpha * <g,d>);
C
C              1 = convergence to the boundary of ||s||_2 <= delta;
C
C              2 = convergence to the boundary of l - x <= s <= u - x;
C
C              3 = stopping with s = sk  such that <gk,sk> <= -t heta 
C                  ||gk||_2 ||sk||_2 and <gk,s_{k+1}> > - theta 
C                  ||gk||_2 ||s_{k+1}||_2;
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, and, for 
C                  all i, 
C
C                  |alpha * d(i)| .le. macheps * max ( |x(i)|, 1.0d0 ). 
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              7 = stopping with d such that d^T H d = 0 and g^T d = 0;
C     
C              8 = it was achieved the maximum allowed number of
C                  function evaluations (maxfc);
C
C              9 = problem in projection subroutine;
C
C             10 = step norm too small;
C      
C            -90 = error in evalf subroutine;
C
C            -92 = error in evalg subroutine.
C
C            < 0 = error in calchd subroutine.
      
      subroutine ingencan(nind, ind, nind2, ind2, n, x, f, g, gz, l, u,
     +     m, meq, nliact, nact, iact, lda, A, b, ldh, H, ldabar, Abar,
     +     tau, sccol, scol, epsnqmp, maxitnqmp, gtype, hptype, trtype,
     +     iprint, ncomp, wi1, wd1, wd2, wd3, wd4, wd5, wd6, wd7, lwd7,
     +     wd8, wd9, wd10, dz, d, delta, delmin, ssupn, sts, nit,
     +     ucgmia, ucgmib, cgscre, cgepsi, cgepsf, acgeps, bcgeps,
     +     gpeucn2, gpsupn, theta, etaint, etaext, mininterp, maxextrap,
     +     fmin, maxfc, gamma, beta, sigma1, sigma2, promaxit, projeps,
     +     ceps, macheps, bignum, ncg, nef, neg, neh, tnintcnt,
     +     tnexgcnt, tnexbcnt, tnintfe, tnexgfe, tnexbfe, tnstpcnt,
     +     tnnef, rbdlu, rbdli, rbdind, inform)     
      
C     SCALAR ARGUMENTS
      logical sccol
      integer nind, nind2, n, m, meq, nliact, nact, lda, ldh, ldabar,
     +     maxitnqmp, gtype, hptype, trtype, iprint, ncomp, nit, cgscre,
     +     lwd7, mininterp, maxextrap, maxfc, promaxit, ncg, nef, neg,
     +     neh, tnintcnt, tnexgcnt, tnexbcnt, tnintfe, tnexgfe, tnexbfe,
     +     tnstpcnt, tnnef, rbdlu, rbdli, inform
      double precision f, epsnqmp, delta, delmin, ssupn, sts, ucgmia,
     +     ucgmib, cgepsi, cgepsf, acgeps, bcgeps, gpeucn2, gpsupn,
     +     theta, etaint, etaext, fmin, gamma, beta, sigma1, sigma2,
     +     projeps, ceps, macheps, bignum

C     ARRAY ARGUMENTS
      integer ind(nind), ind2(nind), iact(m), wi1(n+n+m), rbdind(n+m)
      double precision x(n), g(n), gz(nind-nliact), l(n), u(n),
     +     A(lda,n), b(m), H(ldh,n), Abar(ldabar,nliact), tau(nliact),
     +     scol(n), wd1(n), wd2(n), wd3(n), wd4(n), wd5(n+m), wd6(n),
     +     wd7(lwd7), wd8(n), wd9(n), wd10(n), dz(nind-nliact), d(n)
      
C     LOCAL SCALAR
      integer i, j, ii, jj, jjj, cgnit, nefprev, tnintprev, tnexgprev,
     +     tnexbprev, cgmaxit
      double precision amax, amaxx, deucn2, ad, ax, cgeps

C     Compute trust-region radius
      
      if (nit .gt. 1) then
         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     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-nliact), 10.0d0 *
C     +        log10(dfloat(nind-nliact)))) +
C     +        kappa * dfloat(nind-nliact))
         
         cgmaxit = max(1, min(2 * (nind - nliact), 10000))
      else
         cgmaxit = max(1, int(ucgmia * (nind - nliact) + ucgmib))
      end if
      
      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))
      
C     Evaluate Hessian at x
      
      if (hptype .eq. 1) then
         call calch(n, nind, ind, x, x, sccol, scol, wd1, ldh, H,
     +        inform)

         neh = neh + 1
      end if
      
      if (inform .lt. 0) then
         return
      end if
      
C     Compute the descent direction solving the newtonian system by 
C     conjugate gradients
      
      call cg(nind, ind, nind2, ind2, n, nind-nliact, x, gz, delta, l,
     +     u, m, nact, iact, lda, A, b, ldh, H, ldabar, Abar, tau,
     +     sccol, scol, cgeps, epsnqmp, maxitnqmp, cgmaxit, gtype,
     +     hptype, trtype, iprint, ncomp, wd1, wd2, wd3, wd4, wd5, wd6,
     +     wd7, wd8, wd9, wd10, theta, macheps, bignum, dz, d, deucn2,
     +     cgnit, rbdlu, rbdli, rbdind, wi1, inform)
         
      ncg = ncg + cgnit
      
      if (inform .lt. 0) then
         return
      end if
      
C     Adjustment of step
      
      do i = nind2+1, nind
         ii = ind2(i)
         d(ii) = 0.0d0
      end do
    
      do i = 1, nind
         if (abs(d(i)) .le. macheps * max(abs(x(i)), 1.0d0)) then
            deucn2 = deucn2 - d(i)**2
            d(i) = 0.0d0
         end if
      end do
      
C     If Eclidian-norm of step d is too small and no constraint
C     will be added to the active set, a SPG iteration is forced

      if ((deucn2 .le. macheps) .and. (inform .ne. 2)) then
         inform = 10
         return
      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.0d6)) then
                  amax  = amaxx
                  rbdlu = 1
                  rbdind(rbdlu) = n + ii
               else
                  if (amaxx .le. amax + macheps*max(amax,1.0d6)) 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.0d6)) then
                  amax  = amaxx
                  rbdlu = 1
                  rbdind(rbdlu) = ii
               else
                  if (amaxx .le. amax + macheps*max(amax,1.0d6)) then
                     rbdlu = rbdlu + 1
                     rbdind(rbdlu) = ii
                  end if
               end if
               
            end if
         end do         
         
         call expand(n, nind, ind, x)
         
C        Look to the linear inequality constraints
         
         rbdli = rbdlu
            
         do i = nact+1, m
            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.0d6)) then
                  amax  = amaxx
                  rbdlu = 0
                  rbdli = 1
                  rbdind(rbdli) = i
               else
                  if (amaxx .le. amax + macheps*max(amax,1.0d6)) then
                     rbdli = rbdli + 1
                     rbdind(rbdli) = i
                  end if
               end if
            end if
         end do
         
         call shrink(n, nind, ind, x)
         
      end if
      
C     Perform the line search
      
      tnintprev = tnintcnt
      tnexgprev = tnexgcnt
      tnexbprev = tnexbcnt
      
      nefprev = nef

      call tnls(nind, ind, nind2, ind2, n, x, l, u, m, meq, nact, iact,
     +     lda, A, b, f, g, sccol, scol, d, amax, rbdlu, rbdli, rbdind,
     +     gtype, etaint, etaext, mininterp, maxextrap, fmin, maxfc,
     +     iprint, wd1, wd2, wd3, wi1, wd4, wd7, lwd7, wd5, gamma, beta,
     +     sigma1, sigma2, promaxit, projeps, ceps, macheps, nef, neg,
     +     tnintcnt, tnexgcnt, tnexbcnt, inform)

      if ((inform .lt. 0) .or. (inform .eq. 9)) then
         return
      end if
      
      if (tnintcnt .gt. tnintprev) then
         tnintfe = tnintfe + (nef - nefprev)
      else if (tnexgcnt .gt. tnexgprev) then
         tnexgfe = tnexgfe + (nef - nefprev)
      else if (tnexbcnt .gt. tnexbprev) then
         tnexbfe = tnexbfe + (nef - nefprev)
      else
         tnstpcnt = tnstpcnt + 1
      end if
      
      tnnef = tnnef + (nef - nefprev)
      
      if ((deucn2 .le. macheps) .and. (inform .ne. 11)) then
         inform = 10
         return
      end if

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

C     This subroutine implements the Conjugate Gradients method for 
C     minimizing the quadratic approximation q(s) of f(x) at x, where
C
C     q(s) = 1/2 s^T H s + g^T s,
C
C        H = Z^T \nabla^2 f(x) Z,
C
C        g = Z^T \nabla f(x),
C
C     subject to || s || <= delta and l <= x + s <= u.
C
C     In the constraint ''|| s || <= 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 s to the solution such that 
C     ||H s + g||_2 <= eps * ||g||_2; or converges to the boundary of 
C     ||s||_2 <= delta and l <= x + s <= u; or finds a point s and a 
C     direction d such that q(s + alpha d) = q(s) for any alpha, i.e., 
C     d^T H d = g^T d = 0.
C
C     On Entry
C     
C     nind     integer
C              number of free variables (including the ones used to
C              update QR factorization of Abar)
C
C     ind      integer ind(nind)
C              array which contains, in the first nind positions, the
C              identifiers of the free variables
C
C     nind2    integer
C              number of really free variables
C     
C     ind2     integer ind2(nind)
C              array which contains, in the first nind2 positions, 
C              the indices of ind that contain the real free variables
C      
C     n        integer
C              dimension of the full space
C
C     nred     integer
C              dimension of the reduced space (this is the dimension in 
C              which this subroutine will work). If nliact is the number
C              of linearly independent linear constraints,
C              nred = nind - nliact
C
C     x        double precision x(n)
C              point at which f function 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     g        double precision g(n)
C              linear coefficient of the quadratic function.
C              This is Z^T \nabla f(x).
C
C     delta    double precision
C              trust region radius (||s||_2 <= delta) 
C    
C     l        double precision l(n)
C              lower bounds on x + s. It components are ordered in the 
C              same way as x.
C
C     u        double precision u(n)
C              upper bounds on x + s. It components are ordered in the 
C              same way as x and l.
C      
C     m        integer
C     nact     integer
C     iact     integer iact(m)
C     lda      integer
C     A        double precision(lda,n)
C     b        double precision(m)
C              These five parameters are used but not modified by 
C              CG. They are used to calculate the maximum step
C              length. m is the number of linear constraints in the
C              original problem; nact is the number of linear active
C              constraints; iact stores the indices of linear active
C              constraints; A is the matrix of coeficients of the linear
C              constraits; and b is the right-hand side of the linear
C              constraints. The columns of A are ordered the same way
C              as x
C     
C     ldh      integer
C              leading dimension of matrix H
C     
C     H        double precision H(ldh,n)
C              Hessian of objetive function at x
C
C     ldabar   integer
C              leading dimension of matrix Abar
C     
C     Abar     double precision Abar(ldabar,nact)
C              used to calculate base of null space spanned by active
C              linear constraints. Abar stores the QR factorization of
C              matrix A
C      
C     tau      double precision tau(nact)
C              used to calculate base of null space spanned by active
C              linear constraints
C     
C     sccol    logical
C              true iff variables should be scaled
C
C     scol     double precision scol(n)
C              variable scaling factors
C      
C     eps      double precision
C              tolerance for the stopping criterion ||H s + g||_2 < eps 
C              * ||g||_2
C
C     epsnqmp  double precision
C              See below
C
C     maxitnqmp integer
C              This and the previous one parameter are used for a 
C              stopping criterion of the conjugate gradient 
C              subalgorithm. If the progress in the quadratic model is 
C              less or equal than a fraction of the best progress 
C              ( epsnqmp * bestprog ) during maxitnqmp consecutive 
C              iterations then CG is stopped by not enough progress of 
C              the quadratic model.
C
C              RECOMMENDED: epsnqmp = 1.0d-4, maxitnqmp = 5
C
C     maxit    integer
C              maximum number of iterations allowed
C
C     gtype    integer
C              gtype indicates in which way the gradient of the 
C              objective function will be computed. If the user have 
C              been implemented the user-supplied evalg subroutine to 
C              compute the gradient of the objective function then 
C              gtype argument must be set to 0 (ZERO) and the user-
C              supplied evalg subroutine will be called by GENLIN any 
C              time the gradient would be required.
C
C              RECOMMENDED: gtype = 0 (provided you have the evalg 
C                           subroutine)
C
C              CONSTRAINTS: allowed values are just 0 or 1.
C
C     hptype   integer
C              The way in which the product of the Hessian matrix
C              by a vector will be done depends on the value of the 
C              parameter hptype in the following way:
C
C              = 0, means that a subroutine provided by the user will be
C                   used to compute the Hessian-vector product.
C
C              = 1, 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              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     trtype   integer
C              type of trust-region radius
C              trtype = 0 means 2-norm trust-region
C              trtype = 1 means infinite-norm trust-region
C
C              RECOMMENDED: trtype = 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, GENLIN 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     r        double precision r(nred)
C     d        double precision d(nred)
C     zd       double precision zd(n)
C     sprev    double precision sprev(nred)
C     zsprev   double precision zsprev(n)
C     wd1      double precision wd1(nred)
C     wd2      double precision wd2(n)
C     wd3      double precision wd3(n)
C     wd4      double precision wd4(n)      
C     z        double precision z(nred)
C     rbdposaind
C              integer rbdposaind(m+n)
C              working vectors
C
C     theta    double precision
C              constant for the angle condition, i.e., at iteration k we 
C              need a direction d_k such that <gk,dk> <= - theta 
C              ||gk||_2 ||dk||_2, where gk is \nabla f(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 1.0d+99
C
C     On Return
C
C     s        double precision s(n)
C              final estimation of the solution
C
C     zs       double precision zs(n)
C              final estimation of the solution in the full espace (Z s)
C
C     snorm2   double precision
C              squared Euclidian-norm of s
C      
C     nit      integer
C              number of Conjugate Gradient iterations performed
C
C     rbdlu    integer
C              number of bounds attained at x + zs
C      
C     rbdli    integer
C              rbdli-rbdlu is the number of linear constraints
C              attained at x + zs
C      
C     rbdind   integer rbdind(n+m)
C              indeces of variables (or linear constraints) that are
C              satisfied by equality in x + zs
C     
C     inform   integer
C              termination parameter:
C
C              0 = convergence with ||H s + g||_2 <= eps * ||g||_2;
C
C              1 = convergence to the boundary of ||s||_2 <= delta;
C
C              2 = convergence to the boundary of l - x <= s <= u - x;
C
C              3 = stopping with s = sk  such that <gk,sk> <= -t heta 
C                  ||gk||_2 ||sk||_2 and <gk,s_{k+1}> > - theta 
C                  ||gk||_2 ||s_{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.0d0);
C
C              6 = very similar consecutive iterates, for two 
C                  consecutive iterates x and y, for all i | x(i) - 
C                  y(i) | <= macheps * max ( | x(i) |, 1.0d0 );
C
C              7 = stopping with d such that d^T H d = 0 and g^T d = 0;
C
C              8 = too many iterations;
C
C            < 0 = error in evalhd subroutine.
                 
      subroutine cg(nind, ind, nind2, ind2, n, nred, x, g, delta, l, u, 
     +     m, nact, iact, lda, A, b, ldh, H, ldabar, Abar, tau, sccol,
     +     scol, eps, epsnqmp, maxitnqmp, maxit, gtype, hptype, trtype,
     +     iprint, ncomp, r, d, zd, sprev, zsprev, wd1, wd2, wd3, wd4,
     +     z, theta, macheps, bignum, s, zs, snorm2, nit, rbdlu, rbdli,
     +     rbdind, rbdposaind, inform)

C     SCALAR ARGUMENTS
      logical sccol
      integer nind, nind2, n, nred, m, nact, lda, ldh, ldabar,
     +     maxitnqmp, maxit, gtype, hptype, trtype, iprint, ncomp, nit,
     +     rbdlu, rbdli, inform
      double precision delta, eps, epsnqmp, theta, macheps, bignum,
     +     snorm2 
      
C     ARRAY ARGUMENTS
      integer ind(nind), ind2(nind), iact(m), rbdind(n+m),
     +     rbdposaind(n+m)
      double precision x(n), g(nred), l(n), u(n), A(lda,n), b(m),
     +     H(ldh,n), Abar(ldabar,nind-nred), tau(nind-nred), scol(n),
     +     r(nred), d(nred), zd(n), sprev(nred), zsprev(n), wd1(nred),
     +     wd2(n), wd3(n), wd4(n), z(nred), s(nred), zs(n)

C     LOCAL SCALARS
      character * 6 rbdtypea
      logical samep
      integer itnqmp, i, ii, j, jj, nliact, rbdposalu, rbdposali
      double precision aa, alpha, amax, amax1, amax2, amax2x, bb,
     +     bestprog, beta, cc, currprog, dd, dnorm2, dtr, dts, dtw,
     +     gnorm2, gts, norm2s, q, qprev, rnorm2, ax, azs, azd, ztr,
     +     ztrprev, znorm2, gtd
      
C     ==================================================================
C     Initialization
C     ==================================================================

      nliact   = nind - nred
      gnorm2   = norm2s(nred, g)
      
      nit      =      0
      itnqmp   =      0
      qprev    = bignum
      bestprog =  0.0d0
      
      do i = 1, nred
         s(i) = 0.0d0
         r(i) =  g(i)
      end do
      
      do i = 1, nind
         zs(i) = 0.0d0
         zsprev(i) = 0.0d0
      end do
      
      q      =  0.0d0
      gts    =  0.0d0
      snorm2 =  0.0d0
      rnorm2 = gnorm2
      ztr    =  0.0d0
      
C     ==================================================================
C     Print initial information
C     ==================================================================

      if (iprint .ge. 3) then
         write(*, 980) 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) nit, rnorm2, sqrt(snorm2), q
         
         write(10,980) 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) nit, rnorm2, sqrt(snorm2), q
         
      end if
      
C     ==================================================================
C     Main loop
C     ==================================================================
      
 100  continue
      
C     ==================================================================
C     Test stopping criteria
C     ==================================================================

C     if ||r||_2 = ||H s + g||_2 <= eps * ||g||_2 then stop

      if ((nit .ne. 0) .and. (((rnorm2 .le. eps ** 2 * gnorm2) .and.
     +     (nit .ge. 4)) .or. (rnorm2 .le. 1.0d-12))) 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 (nit .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     ==================================================================

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

      ztrprev = ztr
      ztr     = rnorm2
      znorm2  = rnorm2
      
C     ==================================================================
C     Compute direction
C     ==================================================================

      if (nit .eq. 0) then
         
         do i = 1, nred
            d(i) = - z(i)
         end do
         
         dtr    = - ztr
         dnorm2 =   znorm2
         
      else
         
         beta = ztr / ztrprev
         
         do i = 1, nred
            d(i) = - z(i) + beta * d(i)
         end do
         
         dnorm2 = rnorm2 - 2.0d0 * beta * (dtr + alpha * dtw) + 
     +        beta**2 * dnorm2
         dtr    = - rnorm2 + beta * (dtr + alpha * dtw)
         
      end if

C     Force d to be a descent direction of q(s), i.e.,
C     <\nabla q(s), d> = <H s + g, d> = <r, d> \le 0.

      if (dtr .gt. 0.0d0) then
         
         do i = 1, nred
            d(i) = - d(i)
         end do
         
         dtr = - dtr
         
      end if
      
C     ==================================================================
C     Compute d^T Z^T H Z d
C     ==================================================================

C     wd1 = Z^T H Z d

C     Calculate zd = Z d. Then, wd2 = H zd and wd1 = Z^T wd2 = Z^T H Z d

      if (hptype .eq. 0) then
         
         if (nliact .eq. 0) then
            do i = 1, nind
               zd(i) = d(i)
            end do
            
            if (sccol) then
               do i = 1, n
                  ii = ind(i)
                  wd2(i) = x(i) * scol(ii)
               end do
               
               call evalhdb(nind, ind, n, wd2, zd, wd1, inform)
               
               do i = 1, nind
                  ii = ind(i)
                  wd1(i) = wd1(i) * scol(ii)
               end do
            else
               call evalhdb(nind, ind, n, x, zd, wd1, inform)
            end if
            
         else
            call multZ(nind, nliact, ldabar, Abar, tau, d, zd, macheps)
            
            if (sccol) then
               do i = 1, n
                  ii = ind(i)
                  wd1(i) = x(i) * scol(ii)
               end do
               
               call evalhdb(nind, ind, n, wd1, zd, wd2, inform)
               
               do i = 1, nind
                  ii = ind(i)
                  wd2(i) = wd2(i) * scol(ii)
               end do
            else
               call evalhdb(nind, ind, n, x, zd, wd2, inform)   
            end if
            
            call multZT(nind, nliact, ldabar, Abar, tau, wd2, wd3, wd1,
     +           macheps)            
         end if 

C     Calculate wd1 = Z^T H Z d
         
      else if (hptype .eq. 1) then
         call calchd(n, nind, ind, nliact, ldh, H, ldabar, Abar, tau, d,
     +        wd2, wd3, zd, wd1, macheps, inform)
         
C     Approximate H and, then, calculate wd1 = Z^T H Z d
         
c      else if (hptype .eq. 4) then
c         call
c         call calchd(n, nind, ind, nliact, ldh, H, ldabar, Abar, tau, d, wd2,
c     +        wd3, zd, wd1, macheps, inform)
         
C     Approximate product Z^T H Z d
         
      else if (hptype .eq. 9) then
         call calchddiff(n, nind, ind, x, x, nliact, ldabar, Abar, tau,
     +        sccol, scol, d, g, gtype, macheps, wd2, wd3, wd4, zd, wd1,
     +        inform)
      end if
      
      if (inform .lt. 0) then
         if (iprint .ge. 3) then
            write(*, 1000) inform
            write(10,1000) inform
         end if
         
         return
      end if
      
C     Compute d^T wd1

      dtw = 0.0d0
      do i = 1, nred
         dtw = dtw + d(i) * wd1(i)
      end do 
      
C     ==================================================================
C     Compute maximum step
C     ==================================================================

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

      dts = 0.0d0
      do i = 1, nred
         dts = dts + d(i) * s(i)
      end do
      
C     Euclidian-norm trust radius

      if (trtype .eq. 0) then

         aa = dnorm2
         bb = 2.0d0 * dts
         cc = snorm2 - delta**2
         dd = sqrt(bb**2 - 4.0d0 * aa * cc)
         
         amax1  = (- bb + dd) / (2.0d0 * aa)
         
C     Sup-norm trust radius

      else if (trtype .eq. 1) then
         
         amax1  =  bignum
         
         do i = 1, nred
            if (d(i) .gt. 0.0d0) then
               amax1  = min(amax1, (  delta - s(i)) / d(i))
            else if (d(i) .lt. 0.0d0) then
               amax1  = min(amax1, (- delta - s(i)) / d(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 (zd(ii) .gt. 0.0d0) then
            amax2x = (u(ii) - x(ii) - zs(ii)) / zd(ii)

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

            if (amax2x .lt. amax2 - macheps * max(amax2, 1.0d6)) then
               amax2     = amax2x
               rbdposalu = 1
               rbdposaind(rbdposalu) = ii
            else
               if (amax2x .le. amax2 + macheps * max(amax2,1.0d6)) then
                  rbdposalu = rbdposalu + 1
                  rbdposaind(rbdposalu) = ii
               end if
            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

      call expand(n, nind, ind, x)

C     Look to the linear inequality constraints
      
      rbdposali = rbdposalu

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

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

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

      call shrink(n, nind, ind, x)

C     Compute amax as the minimum among amax1 and amax2

      amax = min(amax1, amax2)
      
C     ==================================================================
C     Compute the step (and the quadratic functional value at the new 
C     point)
C     ==================================================================

C     If d^T H d > 0 then take the conjugate gradients step

      if (dtw .gt. 0.0d0) then
         
         alpha = min(amax, ztr / dtw)

C     Else, if we are at iteration zero then take the maximum positive
C     step in the minus gradient direction
         
      else if (nit .eq. 0) then
         
         alpha = amax
            
C     Else, stop at the current point

      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     ==================================================================

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

      gts = gts + alpha * gtd
      
      if ((gts .gt. 0.0d0) .or. 
     +     (gts**2 .lt. theta**2 * gnorm2 * snorm2)) then
         
         inform = 3
         
         if (iprint .ge. 3) then
            write(*, 994) inform
            write(10,994) 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 * dtw + alpha * dtr
      
C     ==================================================================
C     Compute new s
C     ==================================================================

      do i = 1, nred
         sprev(i) = s(i)
         s(i)     = s(i) + alpha * d(i)
      end do
      
      do i = 1, nind
         zsprev(i) = zs(i)
         zs(i)     = zs(i) + alpha * zd(i)
      end do
      
      snorm2 = snorm2 + alpha**2 * dnorm2 + 2.0d0 * alpha * dts
      
C     ==================================================================
C     Compute the residual r = H s + g
C     ==================================================================

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

      rnorm2 = norm2s(nred, r)

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

      nit = nit + 1

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

      if (iprint .ge. 3) then
         write(*, 984) nit, sqrt(rnorm2), sqrt(snorm2), q
         write(10,984) nit, sqrt(rnorm2), sqrt(snorm2), q
      end if

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

C     If we are in the boundary of the feasible set also stop

      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
         end if
         
         inform = 2

         if (iprint .ge. 3) then
            if (rbdlu .eq. 0) then
               write(*, 993) inform, rbdind(1)
               write(10,993) 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

         go to 500
         
      end if

C     If we are in the boundary of the trust region then stop

      if (alpha .eq. amax1) then
         
         inform = 1
         
         if (iprint .ge. 3) then
            write(*, 991) inform
            write(10,991) inform
         end if
  
         go to 500
          
      end if

C     If two consecutive iterates are much close then stop
      
      samep = .true.
      do i = 1, nred
         if (abs(alpha * d(i)) .gt. macheps*max(abs(s(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     Test whether we performed many iterations without good progress of
C     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(*, 995) inform, itnqmp, epsnqmp, bestprog
               write(10,995) inform, itnqmp, epsnqmp, bestprog
            end if
            
            go to 500
         end if
         
      else
         itnqmp = 0
      end if

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),
     +        (s(i), i = 1, min0(nred, ncomp))
         write(10,985) min0(nred, ncomp),
     +        (s(i), i = 1, min0(nred, ncomp))
      end if
      
      return

C     Non-executable statements

 980  format(/,6x,'Conjugate gradients (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,' snorm= ',1PD11.4,
     +     ' q= ',1PD11.4)
 985  format(/,6x,'Truncated Newton direction (first ',I6, 
     +     ' components): ',/,1(6x,6(1PD11.4,1x)))
 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)')
 993  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)')      
 994  format(6x,'Flag of CG = ',I3,
     +  ' (The etaext CG iterate will not satisfy the angle condition)')
 995  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,
     +     ' (d such that d^T H d = 0 and g^T d = 0 was found)')
 998  format(6x,'Flag of CG = ',I3,' (Too many GC iterations)')
 1000 format(6X,'Flag of CG = ',I3,' Fatal Error')
      
      end

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

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 (including the ones used to
C              update QR factorization of Abar)
C
C     ind      integer ind(nind)
C              array which contains, in the first nind positions, the
C              identifiers of the free variables
C
C     nind2    integer
C              number of really free variables
C     
C     ind2     integer ind2(nind)
C              array which contains, in the first nind2 positions, 
C              the indices of ind that contain the real 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     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     m        integer
C     meq      integer
C     lda      integer
C     A        double precision(lda,n)
C     b        double precision(m)
C              These five parameters are used but not modified by 
C              TNLS. They are used to project (extrapolation). 
C              m is the number of linear constraints in the
C              original problem; meq is the number of linear equality
C              constraints; A is the matrix of coeficients of the linear
C              constraits; and b is the right-hand side of the linear
C              constraints
C
C     nact     integer
C              number of linear active constraints
C     
C     iact     integer iact(m)
C              stores the indices of linear active constraints
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     sccol    logical
C              true iff variables should be scaled
C
C     scol     double precision scol(n)
C              variable scaling factors
C      
C     d        double precision d(nind)
C              descent direction 
C    
C     amax     double precision
C              maximum step length to maintain feasibility
C      
C     rbdlu    integer
C              number of bounds attained at x + zs
C      
C     rbdli    integer
C              rbdli-rbdlu is the number of linear constraints
C              attained at x
C
C     rbdind   integer rbdind(n+m)
C              indeces of variables (or linear constraints) that are
C              satisfied by equality in x + zs
C
C     gtype    integer
C              0, if user provided true gradient;
C              1, if gradient is to be approximated
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     etaext   double precision
C              constant for the extrapolation
C              when extrapolating we try alpha_new = alpha * etaext
C
C              RECOMMENDED: etaext = 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     maxextrap integer
C              constant to limit the number of extrapolations
C
C              RECOMMENDED: maxextrap = 1000 (a big number)
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     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, GENLIN 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     xplus    double precision xplus(nind)
C     xtmp     double precision xtmp(nind)
C     xbext    double precision xbext(nind) 
C     wi1      integer wi(n+n+m)
C     wd1      double precision wd1(n) 
C     wd2      double precision wd2(lwd2) 
C     wd3      double precision wd3(m) 
C              working vectors
C
C     lwd2     integer
C              size of array wd2. Must be, at least, 1.5*n*n+10*n+m
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     beta     double precision
C              constant for the beta condition <dk, g(xk + dk)>  <  beta 
C              * <dk,gk>. If (xk + dk) satisfies the Armijo condition 
C              but does not satisfy the beta condition then the point is 
C              accepted, but if it satisfied the Armijo condition and 
C              also satisfies the beta condition then we know that there 
C              is the possibility for a successful extrapolation
C
C              RECOMMENDED: beta = 0.5
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     promaxit integer
C              maximum allowed number of iterations for projection
C      
C              RECOMMENDED: promaxit = 5000
C
C              CONSTRAINTS: promaxit > 0
C
C     projeps  double precision
C              error allowed in projection
C
C              RECOMMENDED: projeps = 1.0d-13
C
C              CONSTRAINTS: projeps > 0
C
C     ceps     double precision
C              error allowed to consider some point x unfeasible
C              (with respect to linear constaints)
C
C              RECOMMENDED: ceps = 1.0d-05
C
C              CONSTRAINTS: ceps > 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     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     nef      integer
C              number of functional evaluations used in this line search
C
C     neg      integer
C              number of gradient evaluations used in this line search
C
C     intcnt   integer
C              number of interpolations
C
C     exgcnt   integer
C              number of good extrapolations
C
C     exbcnt   integer
C              number of bad extrapolations
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              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, and, for 
C                  all i, 
C
C                  |alpha * d(i)| .le. macheps * max ( |x(i)|, 1.0d0 ). 
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            -90 = error in evalf subroutine;
C
C            -92 = error in evalg subroutine.
      
      subroutine tnls(nind, ind, nind2, ind2, n, x, l, u, m, meq, nact,
     +     iact, lda, A, b, f, g, sccol, scol, d, amax, rbdlu, rbdli,
     +     rbdind, gtype, etaint, etaext, mininterp, maxextrap, fmin,
     +     maxfc, iprint, xplus, xtmp, xbext, wi1, wd1, wd2, lwd2, wd3,
     +     gamma, beta, sigma1, sigma2, promaxit, projeps, ceps,
     +     macheps, nef, neg, intcnt, exgcnt, exbcnt, inform)

C     SCALAR ARGUMENTS
      logical sccol
      integer nind, nind2, n, m, meq, nact, lda, rbdlu, rbdli, gtype,
     +     mininterp, maxextrap, maxfc, iprint, lwd2, promaxit, nef,
     +     neg, intcnt, exgcnt, exbcnt, inform
      double precision f, amax, etaint, etaext, fmin, gamma, beta,
     +     sigma1, sigma2, projeps, ceps, macheps

C     ARRAY ARGUMENTS
      integer ind(nind), ind2(nind), iact(n+n+m), rbdind(n+m),
     +     wi1(n+n+m)
      double precision x(n), l(n), u(n), A(lda,n), b(m), g(n), scol(n),
     +     d(n), xplus(n), xtmp(n), xbext(n), wd1(n), wd2(lwd2), wd3(m)

C     LOCAL SCALARS
      logical samep
      integer interp, i, ii, j, index
      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

      call calcf(n, nind, ind, xplus, x, sccol, scol, wd1, fplus,
     +     inform)
      nef = nef + 1

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

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

         if (gtype .eq. 0) then
            call calcg(n, nind, ind, x, x, sccol, scol, wd1, g, inform)
         else
            call calcgdiff(n, nind, ind, x, x, sccol, scol, wd1, g,
     +           macheps, inform)
         end if
         neg = neg + 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 (nef .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

            if (gtype .eq. 0) then
               call calcg(n, nind, ind, x, x, sccol, scol, wd1, g,
     +              inform)
            else
               call calcgdiff(n, nind, ind, x, x, sccol, scol, wd1, g,
     +              macheps, inform)
            end if
            neg = neg + 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     Print initial information

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

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

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

      if (amax .gt. 1.0d0) 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

            call extrapolation(n, nind, ind, nind2, ind2, x, l, u, m,
     +           meq, nact, iact, lda, A, b, sccol, scol, f, g, gtype,
     +           xplus, fplus, d, wi1, wd1, wd2, lwd2, wd3, alpha, amax,
     +           gtd, rbdlu, rbdli, rbdind, fmin, maxfc, promaxit,
     +           projeps, ceps, macheps, beta, etaext, maxextrap,
     +           iprint, xbext, xtmp, nef, neg, exgcnt, exbcnt, inform)

C           If new point x is in the boundary, rbdind is updated

            if (inform .eq. 12) then 
               rbdlu = 0
               
               do i = 1, nind2
                  ii = ind2(i)
                  
                  if (x(ii) .le. l(ii) + 
     +                 macheps * max(abs(l(ii)), 1.0d6)) then
                     x(ii) = l(ii)
                     rbdlu = rbdlu + 1
                     rbdind(rbdlu) = ii
                  else if (x(ii) .ge. u(ii) -
     +                    macheps * max(abs(u(ii)), 1.0d6)) then
                     x(ii) = u(ii)
                     rbdlu = rbdlu + 1
                     rbdind(rbdlu) = ii + n
                  end if
               end do
               
C              Look to the linear inequality constraints
               
               call expand(n, nind, ind, x)
            
               rbdli = rbdlu

               do i = 1, m-nact
                  wd3(i) = 0.0d0
               end do

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

               do i = nact+1, m
                  ii = iact(i)
                  
                  if (wd3(i-nact) .le. b(ii) +
     +                 macheps * max(abs(b(ii)), 1.0d6)) then
                     rbdli = rbdli + 1
                     rbdind(rbdli) = i
                  end if
               end do
               
               call shrink(n, nind, ind, x)    
               
               if (rbdli .gt. 0) then
                  inform = 11
               else
                  inform = 0
               end if

            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
            
C           Extrapolate
            if (iprint .ge. 3) then
               write(*, *) '     f(x+d) < f(x)'
               write(*, *) '     We will extrapolate'
               write(10,*) '     f(x+d) < f(x)'
               write(10,*) '     We will extrapolate'
            end if

            call extrapolation(n, nind, ind, nind2, ind2, x, l, u, m,
     +           meq, nact, iact, lda, A, b, sccol, scol, f, g, gtype,
     +           xplus, fplus, d, wi1, wd1, wd2, lwd2, wd3, alpha, amax,
     +           gtd, rbdlu, rbdli, rbdind, fmin, maxfc, promaxit,
     +           projeps, ceps, macheps, beta, etaext, maxextrap,
     +           iprint, xbext, xtmp, nef, neg, exgcnt, exbcnt, inform)

C           If new point x is in the boundary, rbdind is updated

            if (inform .eq. 12) then 
               rbdlu = 0
            
               do i = 1, nind2
                  ii = ind2(i)
                  
                  if (x(ii) .le. l(ii) + 
     +                 macheps * max(abs(l(ii)), 1.0d6)) then
                     x(ii) = l(ii)
                     rbdlu = rbdlu + 1
                     rbdind(rbdlu) = ii
                  else if (x(ii) .ge. u(ii) -
     +                    macheps * max(abs(u(ii)), 1.0d6)) then
                     x(ii) = u(ii)
                     rbdlu = rbdlu + 1
                     rbdind(rbdlu) = ii + n
                  end if
               end do
               
C              Look to the linear inequality constraints
               
               call expand(n, nind, ind, x)
            
               rbdli = rbdlu

               do i = 1, m-nact
                  wd3(i) = 0.0d0
               end do
               
               do j = 1, n
                  do i = nact+1, m
                     ii = iact(i)
                     wd3(i-nact) = wd3(i-nact) + A(ii,j) * x(j) 
                  end do
               end do
               
               do i = nact+1, m
                  ii = iact(i)
                  
                  if (wd3(i-nact) .le. b(ii) +
     +                 macheps * max(abs(b(ii)), 1.0d6)) then
                     rbdli = rbdli + 1
                     rbdind(rbdli) = i
                  end if
               end do
               
               call shrink(n, nind, ind, x)    

               inform = 11
               
            end if

            if (inform .eq. 0) then
               inform = 11
            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
      
      interp = 0
      
 210  continue

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

         if (gtype .eq. 0) then
            call calcg(n, nind, ind, x, x, sccol, scol, wd1, g, inform)
         else
            call calcgdiff(n, nind, ind, x, x, sccol, scol, wd1, g,
     +           macheps, inform)
         end if
         neg = neg + 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 = 11
         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

      if (alpha .lt. sigma1) then
         alpha = alpha / etaint      
         
      else
         atmp = (- gtd * alpha**2) / 
     +          (2.0d0 * (fplus - f - alpha * gtd))
         
         if ((atmp .lt. sigma1) .or. (atmp .gt. sigma2 * alpha)) then
            alpha = alpha / etaint
            
         else
            alpha = atmp
         end if
      end if
      
C     Compute new trial point
      
      do i = 1, nind
         xplus(i) = x(i) + alpha * d(i)
      end do
      
      call calcf(n, nind, ind, xplus, x, sccol, scol, wd1, fplus,
     +     inform)
      nef = nef + 1
      
      if (inform .lt. 0) then
         
         if (iprint .ge. 3) then
            write(*, 1000) inform
            write(10,1000) inform
         end if
         
         return
      end if

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

         if (gtype .eq. 0) then
            call calcg(n, nind, ind, x, x, sccol, scol, wd1, g, inform)
         else
            call calcgdiff(n, nind, ind, x, x, sccol, scol, wd1, g,
     +           macheps, inform)
         end if
         neg = neg + 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 (nef .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

            if (gtype .eq. 0) then
               call calcg(n, nind, ind, x, x, sccol, scol, wd1, g,
     +              inform)
            else
               call calcgdiff(n, nind, ind, x, x, sccol, scol, wd1, g,
     +              macheps, inform)
            end if
            neg = neg + 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     Print information of this iteration
      
      if (iprint .ge. 3) then
         write(*, 999) alpha, fplus, nef
         write(10,999) alpha, fplus, nef
      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         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

C         if ( fplus .lt. f ) then

C             f = fplus

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

C             if ( gtype .eq. 0 ) then
C                 call calcg(nind,ind,x,n,x,m,lambda,rho,equatn,linear,g,
C    +            inform)
C             else if ( gtype .eq. 1 ) then
C                 call calcgdiff(nind,ind,x,n,x,m,lambda,rho,equatn,linear,
C    +            g,sterel,steabs,inform)
C             end if
C             neg = neg + 1

C             if ( inform .lt. 0 ) then 

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

C                 return

C             end if

C         end if

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     ==================================================================

 500  continue

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

      return

C     Non-executable statements

 980  format(/,6X,'TN Line search (alphamax= ',1PD11.4,')')
 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)')
 999  format(6X,'Alpha= ',1PD11.4,' F= ',1PD11.4,' FE= ',I5)
 1000 format(6X,'Flag of TN Line search = ',I3,' Fatal Error')

      end

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

C     Last update of INNER (or any of its dependencies): 
C     May 4th, 2006.
C     See report of modifications at the end of this file.
C
C     ------------------------------------------------------------------
C
C     Algorithm that finds a unconstrained minimizer of objective 
C     function inside the box of constraints, hits the boundary 
C     (obtaining function decrease), or finds an interior point where 
C     the objective function has sufficient decrease (compared to its 
C     value at x). Extrapolation may be done.
C
C     When the current point x is "close to" the boundary, a Spectral 
C     Projected Gradient (SPG) iteration is used to calculate the new 
C     point. If this new point is at the boundary, the algorithm stops. 
C     Otherwise, a new iteration begins.
C
C     When x is "far from" the boundary, trust-region radius is 
C     determined and d is calculated using More-Sorensen algorithm to 
C     solve the trust-region subproblem (which is to find a minimizer a 
C     to a function quadratic model provided that the minimizer's 
C     Euclidian-norm is smaller than a given delta). The new point is
C     xtrial = x + d. 
C
C     If xtrial lies outside the box of constraints, it is truncated on 
C     the boundary. This new y on the boundary will be candidate to be a 
C     solution. If function value at new xtrial is smaller than function 
C     value at x, inner algorithm stops with xtrial. Otherwise, the 
C     trust-region radius is decreased so that the new solution d' to 
C     the trust-region subproblem makes x + d' be interior to the box.
C     More-Sorensen algorithm is used to calculate d' too.
C
C     If xtrial lies inside the box, sufficient decrease of objective 
C     function is tested. If it is true, xtrial is accepted as a solution
C     candidate. If xtrial in on the boundary, inner algorithm stops and 
C     if it is interior, a new iteration begins. If sufficient decrease is 
C     not obtained, trust-region radius is decreased and a new quadratic 
C     model minimizer is calculated (as in a classical trust-region 
C     algorithm for unconstrained minimization).
C
C     If the user wants, after calculating the candidate solution xtrial, 
C     extrapolation may be performed. For this, set extrpi to true, 
C     where i is the step of the inner algorithm that can call 
C     extrapolation procedure. If extrp4 is true, extrapolation will be
C     tried after xtrial hit the boundary. And if extrp5 is true,
C     extrapolation will be tried after xtrial is calculated by
C     trust-region algorithm, when xtrial is interior and provides
C     sufficient decrease of objective function.
C
C     If gradient at current point is null, inner algorithm stops 
C     declaring "first-order stationary point". If quadratic model 
C     minimum is 0, inner algorithm stops declaring "second-order 
C     stationary point".
C
C     On Entry
C      
C     n        integer
C              dimension of full space
C
C     nind     integer
C              number of free variables (including the ones used to
C              update QR factorization of Abar)
C
C     ind      integer ind(nind)
C              array which contains, in the first nind positions, the
C              identifiers of the free variables
C
C     nind2    integer
C              number of really free variables
C     
C     ind2     integer ind2(nind)
C              array which contains, in the first nind2 positions, 
C              the indices of ind that contain the real 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     m        integer
C              number of linear constraints
C
C     meq      integer
C              number of equality linear constraints
C     
C     nliact   integer
C              number of linear independent active constraints
C     
C     nact     integer
C              number of linear active constraints
C     
C     iact     integer iact(m)
C              stores the indices of linear active constraints
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(m)
C              right-hand side of linear constraints
C     
C     ldabar   integer
C              leading dimension of matrix Abar
C     
C     Abar     double precision Abar(ldabar,nact)
C              used to calculate base of null space spanned by active
C              linear constraints. Abar stores the QR factorization of
C              matrix A
C      
C     tau      double precision tau(nact)
C              used to calculate base of null space spanned by active
C              linear constraints
C
C     sccol    logical
C              true iff variables should be scaled
C
C     scol     double precision scol(n)
C              variable scaling factors
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, that is, gz = Z^T g
C      
C     gzsupn   double precision
C              gz sup-norm
C      
C     gtype    integer
C              0, if user provided true gradient;
C              1, if gradient is to be approximated
C
C     delta    double precision 
C              trust-region radius
C
C     lamms    double precision
C              value that More-Sorensen algorithm calculates to find 
C              the trust-region subproblem solution (MEQB)
C
C     rhoms    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              box of constraints)
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     sigms    double precision
C              allowed error to trust-region subproblem solution 
C              (MEQB)
C
C     etaext   double precision
C              size of extrapolation
C
C     maxextrap integer
C              constant to limit the number of extrapolations
C 
C     beta     double precision
C              used to decide whether or not extrapolation must be 
C              performed
C
C     trgamma  double precision
C              sufficient decrease occurs when ared >= trgamma*pred
C
C     delmin   double precision
C              minimum value for trust-region radius (delta) in the 
C              beginning of each iteration
C
C     delmax   double precision
C              maximum value for trust-region radius (delta) on each 
C              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     promaxit integer
C              maximum allowed number of iterations for projection
C      
C     projeps  double precision
C              error allowed in projection
C
C     ceps     double precision
C              error allowed to consider some point x unfeasible
C              (with respect to linear constaints)
C
C     macheps  double precision
C              macheps is the smallest positive number such that
C              1 + macheps is not equal to 1
C
C     nit      integer
C              number of current outer iteration
C
C     iprint   integer
C              Commands printing. Nothing is printed if iprint is 
C              smaller than 3.
C
C     xeucn2   double precision
C              x squared Euclidian norm
C
C     gpeucn2  double precision
C              projected-gradient 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     diag     double precision diag(n)
C     d        double precision d(n)
C     dz       double precision dz(nind-nliact)
C     xtrial   double precision xtrial(n)
C     wi1      integer wi1(m+n+n)
C     wd1      double precision wd1(n)
C     wd2      double precision wd2(n)
C     wd3      double precision wd3(n)
C     wd4      double precision wd4(lwd4)      
C     wd5      double precision wd5(m)
C              working vectors 
C
C     lwd4     integer
C              size of wd4
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     nef      integer
C              total number of function evaluations
C
C     neg      integer
C              total number of gradient evaluations
C
C     neh      integer
C              total number of Hessian evaluations
C
C     nch      integer
C              number of Cholesky decompositions
C
C     spginit  integer
C              number of inner SPG iterations
C
C     spginef  integer
C              number of function evaluations performed by inner SPG
C
C     trnit    integer
C              number of Trust-region iterations
C      
C     trnef    integer
C              number of Trust-region function evaluations
C
C     trexgcnt integer
C              number of well-succeeded extrapolations
C
C     trexbcnt integer
C              number of not well-succeeded extrapolations
C
C     trexgfe  integer
C              number of function evaluations performed during
C              well-succeeded extrapolations
C      
C     trexbfe  integer
C              number of function evaluations performed during not
C              well-succeeded extrapolations
C      
C     delta    double precision
C              updated trut-region radius
C
C     lamms    double precision
C              updated value for next iteration (see entry parameter)
C
C     rbdlu    integer
C              number of bounds attained at x + d
C      
C     rbdli    integer
C              rbdli-rbdlu is the number of linear constraints
C              attained at x + d
C      
C     rbdind   integer rbdind(n+m)
C              indeces of variables (or linear constraints) that are
C              satisfied by equality in x + d
C     
C     ittype   character *4
C              iteration type: 
C                TR, for trust-region;
C              iSPG, for inner SPG;
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              4 = if a very small function value is achieved;
C
C              5 = if trust-region radius is too small;
C
C              6 = if step taken by inner SPG is too small;
C      
C              8 = if maximum allowed number of function evaluations is 
C                  achieved;
C      
C             11 = if x hit the boundary;
C
C            -90 = if an error occurred during function evaluation;
C
C            -92 = if an error occurred during gradient evaluation;
C
C            -94 = if an error occurred during hessian evaluation

      subroutine inbetra(n, nind, ind, nind2, ind2, x, l, u, m, meq,
     +     nliact, nact, iact, lda, A, b, ldabar, Abar, tau, sccol,
     +     scol, f, g, gz, gzsupn, gtype, delta, lamms, rhoms, mseps,
     +     msmaxit, phieps, sigms, etaext, maxextrap, beta, trgamma,
     +     delmin, delmax, epsg, gamma, lspgmi, lspgma, sigma1, sigma2,
     +     etaint, mininterp, fmin, promaxit, projeps, ceps, macheps,
     +     nit, iprint, xeucn2, gpeucn2, sts, sty, maxfc, ldh, H, diag,
     +     dz, d, xtrial, wi1, wd1, wd2, wd3, wd4, lwd4, wd5, rbdlu,
     +     rbdli, rbdind, nef, neg, neh, nch, spginit, spginef, trnit,
     +     trnef, trexgcnt, trexbcnt, trexgfe, trexbfe, ittype, inform)
            
C     SCALAR ARGUMENTS     
      integer n, nind, nind2, m, meq, nliact, nact, lda, ldabar, gtype,
     +     msmaxit, maxextrap, mininterp, promaxit, nit, iprint, maxfc,
     +     ldh, lwd4, rbdlu, rbdli, nef, neg, neh, nch, spginit,
     +     spginef, trnit, trnef, trexgcnt, trexbcnt, trexgfe, trexbfe,
     +     inform
      double precision f, gzsupn, delta, lamms, rhoms, mseps, phieps,
     +     sigms, etaext, beta, trgamma, delmin, delmax, epsg, gamma,
     +     lspgmi, lspgma, sigma1, sigma2, etaint, fmin, projeps, ceps,
     +     macheps, xeucn2, gpeucn2, sts, sty
      character*4 ittype
      logical sccol
      
C     ARRAY ARGUMENTS
      integer ind(nind), ind2(nind), iact(m), wi1(m+n+n), rbdind(n+m)
      double precision x(n), l(n), u(n), A(lda,n), b(m),
     +     Abar(ldabar,nliact), tau(nliact), scol(n), g(n),
     +     gz(nind-nliact), H(ldh,n), diag(n), d(n), dz(nind-nliact),
     +     xtrial(n), wd1(n), wd2(n), wd3(n), wd4(lwd4), wd5(m)
      
C     LOCAL SCALARS
      logical linear
      integer i, ii, j, jj, jjj, index, infotmp, nred, nefprev,
     +     trexgprev, trexbprev, restr
      double precision dbound, tmax, pred, ared, deucn, deucn2, tmp,
     +     phi, ftrial, lamspg, ax, ad, amax, fprev
            
      nred     = nind - nliact
      ittype   = 'TR  ' 

      delta = max(delta, 1.0d0)
      
C     Print presentation information

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

C     ==================================================================
C     Compute distance to the boundary
C     ==================================================================
      
C     step 1: calculate the distance between x and the boundary.
C             dbound is the largest positive delta such that the ball 
C             centered at x with radius delta is still inside the box 
C             (set of constraints).
      
      dbound = 1.0d+30

      do i = 1, nind2
         ii = ind2(i)
         if (x(ii) - l(ii) .lt. dbound) then
             restr = ii
         end if
         dbound = min(dbound, x(ii) - l(ii))
      end do

      do i = 1, nind2
         ii = ind2(i)
         if (u(ii) - x(ii) .lt. dbound) then
             restr = ii
         end if
         dbound = min(dbound, u(ii) - x(ii))
      end do

C     Look to the linear inequality constraints

      call expand(n, nind, ind, x)

      do i = 1, m-nact
         wd5(i) = 0.0d0
      end do

      do j = 1, n
         do i = nact+1, m
            ii = iact(i)

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

      call shrink(n, nind, ind, x)

      linear = .false.
      do i = nact+1, m
         ii = iact(i)
         if (wd5(i-nact) - b(ii) .lt. dbound) then
             linear = .true.
             restr = i
         end if

         dbound = min(dbound, wd5(i-nact) - b(ii))
      end do

c      if (iprint .ge. 3) then
c         write(*,*) 'dbound: ', dbound
c         write(*,*) 'linear: ', linear
c         write(*,*) 'indice: ', ii
c         if (linear) then
c            write(*,*) 'Ax: ', wd5(restr-nact), '; b: ', b(iact(restr))
c         else
c            write(*,*) 'l: ',l(restr), '; x: ',x(restr),'; u: ',u(restr)
c         end if
c      end if
      
c      if (linear) then
c          write(*,*) 'dbound: ', dbound
c          write(*,*) 'maior que ', macheps * max(abs(b(restr)), 1.0d0)
c      end if

C     dbound = 1.0d+30
      
C     do i = 1, nind2
C        ii = ind2(i)
C        dbound = min(dbound, x(ii) - l(ii))
C     end do
      
C     do i = 1, nind2
C        ii = ind2(i)
C        dbound = min(dbound, u(ii) - x(ii))
C     end do

C     Look to the linear inequality constraints
      
C     call expand(n, nind, ind, x)

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

C     do i = nact+1, m
C        ii = iact(i)
C        dbound = min(dbound, wd5(i-nact) - b(ii))
C     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) ittype, inform
               write(10,983) ittype, inform
            end if
                        
            return
         end if
         
         ittype  = 'iSPG'
         spginit = spginit + 1
         
         if (nit .eq. 1) then
            lamspg = max(1.0d0, sqrt(xeucn2)) / sqrt(gpeucn2)
         elseif (sty .le. 0.0d0) then
            lamspg = lspgma
         else
            lamspg = sts / sty
         end if
         lamspg = min(lspgma, max(lspgmi, lamspg))
         
C        Shrink columns of A (like x).

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

C        Shrink x, l, u, A to the space of really free variable
C        (using nind2 and ind2).

         call shrink(nind, nind2, ind2, x)
         call shrink(nind, nind2, ind2, g)
         call shrink(nind, nind2, ind2, l)
         call shrink(nind, nind2, ind2, u)
         call shrinkcol(nind, m, nind2, ind2, lda, A)

         nefprev = nef
         
         call spgls(n, nind, ind, nind2, ind2, x, f, g, l, u, m, meq,
     +        nact, iact, lda, A, b, sccol, scol, .true., lamspg,
     +        etaint, mininterp, fmin, maxfc, iprint, xtrial, d, gamma,
     +        sigma1, sigma2, promaxit, projeps, ceps, macheps, wi1,
     +        wd3, wd4, lwd4, wd5, nef, inform)

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

         call expand(nind, nind2, ind2, x)
         call expand(nind, nind2, ind2, g)
         call expand(nind, nind2, ind2, l)
         call expand(nind, nind2, ind2, u)
         call expandcol(nind, m, nind2, ind2, lda, A)

C        Expand columns of A (like x).

         call expandcol(n, m, nind, ind, lda, A)
         
         if ((inform .lt. 0) .or. (inform .eq. 9)) then
            if (iprint .ge. 3) then
               write(*, 989) ittype, inform
               write(10,989) ittype, inform
            end if
            
            return
         end if
        
C        Compute the gradient at the new iterate

         infotmp = inform

         if (gtype .eq. 0) then
            call calcg(n, nind, ind, x, x, sccol, scol, wd1, g, inform)
         else
            call calcgdiff(n, nind, ind, x, x, sccol, scol, wd1, g,
     +           macheps, inform)
         end if       
         neg = neg + 1
         
         if (inform .lt. 0) then
            if (iprint .ge. 3) then
               write(*, 989) ittype, inform
               write(10,989) ittype, inform
            end if
            
            return
         end if
            
         inform = infotmp
            
         if (inform .eq. 4) then
            if (iprint .ge. 3) then
               write(*, 988) ittype, inform
               write(10,988) ittype, inform
            end if
            
            return
            
         elseif (inform .eq. 8) then
            if (iprint .ge. 3) then
               write(*, 987) ittype, inform
               write(10,987) ittype, inform
            end if
            
            return

         else
            go to 7
         end if
         
      end if
      
      ittype = 'TR  '
      trnit  = trnit + 1

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

      call calchz(n, nind, ind, x, x, sccol, scol, nliact, ldabar, Abar,
     +     tau, macheps, wd1, wd2, wd3, ldh, H, diag, inform)
      neh = neh + 1

      if (inform .lt. 0) then
         if (iprint .ge. 3) then
            write(*, 989) ittype, inform
            write(10,989) ittype, 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    if (delta .lt. macheps * 1.0d6) then
         inform = 5
         
         if (iprint .ge. 3) then
            write(*, 986) ittype, inform
            write(10,986) ittype, inform
         end if
         
         return
      end if
      
      call MEQB(nred, gz, ldh, H, diag, delta, sigms, 0.0d0, mseps,
     +     macheps, msmaxit, iprint, wd1, wd2, wd3, lamms, dz, nch,
     +     inform)

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

      if (inform .eq. 5) then
      end if
      
c---  > CALCULAR DIRECAO D DIFERENTE DO MEQB      
       
C     If both internal gradient and Hessian matrix are null, subroutine 
C     MEQB stops with inform = 0 and then the inner algorithm stops 
C     declaring "second-order stationary point".

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

         if (iprint .ge. 3) then
            write(*, 984) ittype, inform
            write(10,984) ittype, 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, wd1, 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) ittype, inform
            write(10,984) ittype, inform
         end if
         
         return
      end if

C     Calculate predicted decrease of objective function
      
      pred = -phi

C     Calculate direction d = Z dz and adjust it.

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

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

      do i = 1, nind
         if (abs(d(i)) .le. macheps * max(abs(x(i)), 1.0d0)) then
            d(i) = 0.0d0
         end if
      end do

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

      do i = 1, nind
         xtrial(i) = x(i) + d(i)
      end do
      
C     Verify if xtrial is inside de box. If not, interior is set to
C     false and tmax is set to the biggest positive scalar such that
C     x + tmax*d is inside the box.
 
      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.0d6)) then
                  tmax = tmp
                  rbdlu = 1
                  rbdind(rbdlu) = ii
               else 
                  if (tmp .le. tmax + macheps * max(tmax, 1.0d6)) 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.0d6)) then
                     tmax = tmp
                     rbdlu = 1
                     rbdind(rbdlu) = ii + n
                  else
                     if (tmp .le. tmax + macheps * max(tmax,1.0d6)) 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
            
      do i = nact+1, m
         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.0d6)) then
                  tmax  = tmp
                  rbdlu = 0
                  rbdli = 1
                  rbdind(rbdli) = i
               else
                  if (tmp .le. tmax + macheps * max(tmax, 1.0d6)) 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 box, xtrial = x + d is replaced
C     by xtrial = x + tmax*d. Now xtrial is definitely interior. Actually,
C     it is in the boundary. If the objective function decreases in
C     xtrial, the inner algorithm stops with xtrial as a solution.
C     Otherwise, a new trust-region radius delta is chosen (smaller than
C     dbound) and a new quadratic model minimizer is calculated (which
C     is necessarily interior because of the choice of delta).

      if (rbdli .gt. 0) then

         if (iprint .ge. 3) then
            write(*, *) '     x+d is not interior to set of constraints'
            write(10,*) '     x+d is not interior to set of constraints'
         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

         call calcf(n, nind, ind, xtrial, x, sccol, scol, wd1, ftrial,
     +        inform)

         nef   = nef + 1
         trnef = trnef + 1
         
         if (inform .lt. 0) then
            if (iprint .ge. 3) then
               write(*, 989) ittype, inform
               write(10,989) ittype, inform
            end if
            
            return
         end if
         
C        Test whether the number of functional evaluations is exhausted

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

            if (gtype .eq. 0) then
               call calcg(n, nind, ind, x, x, sccol, scol, wd1, g,
     +              inform)
            else
               call calcgdiff(n, nind, ind, x, x, sccol, scol, wd1, g,
     +              macheps, inform)
            end if                   
            neg = neg + 1

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

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

            if (gtype .eq. 0) then
               call calcg(n, nind, ind, x, x, sccol, scol, wd1, g,
     +              inform)
            else
               call calcgdiff(n, nind, ind, x, x, sccol, scol, wd1, g,
     +              macheps, inform)
            end if 
            neg = neg + 1

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

               if (iprint .ge. 3) then
                  write(*, 988) ittype, inform
                  write(10,988) ittype, inform
               end if
            end if
            
            return
         end if      
         
C        Test if function value decreases at xtrial
         
         if (ftrial .lt. 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 used)

            delta = max(2.0d0 * delta, delmin)
            delta = min(delta, delmax)
                              
            if (maxextrap .gt. 0) then
               
               nefprev   = nef
               trexgprev = trexgcnt
               trexbprev = trexbcnt

               amax = -1.0d0

               fprev = f
               
               call extrapolation(n, nind, ind, nind2, ind2, x, l, u, m,
     +              meq, nact, iact, lda, A, b, sccol, scol, f, g,
     +              gtype, xtrial, ftrial, d, wi1, wd3, wd4, lwd4, wd5,
     +              tmax, amax, tmp, rbdlu, rbdli, rbdind, fmin, maxfc,
     +              promaxit, projeps, ceps, macheps, beta, etaext,
     +              maxextrap, iprint, wd1, wd2, nef, neg, trexgcnt,
     +              trexbcnt, inform)
                     
               if (trexgcnt .gt. trexgprev) then
                  trexgfe = trexgfe + (nef - nefprev)
               else if (trexbcnt .gt. trexbprev) then
                  trexbfe = trexbfe + (nef - nefprev)
               end if
               
               if (inform .lt. 0) then
                  if (iprint .ge. 3) then
                     write(*, 989) ittype, inform
                     write(10,989) ittype, inform
                  end if

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

                  return
               elseif (inform .eq. 4) then
                  if (iprint .ge. 3) then
                     write(*, 988) ittype, inform
                     write(10,988) ittype, inform
                  end if
                  
                  return
               end if

C              Calculate actual reduction of obhective function

               ared = fprev - f

C              Update the trust-region radius (which may be used)
      
               if (ared .lt. 2.5d-1 * pred) then
                  delta = max(2.5d-1 * deucn, delmin)
                  delta = min(delta, delmax)
               else
                  if ((ared .ge. 0.5d0 * pred) .and.
     +               (deucn .ge. delta - macheps*max(delta,1.0d6))) then
                     delta = max(2.0d0 * delta, delmin)
                     delta = min(delta, delmax)
                  else
                     delta = max(delta, delmin)
                     delta = min(delta, delmax)
                  end if
               end if
                              
               if (inform .eq. 12) then
                  inform = 11
                  go to 7
               end if
               
               inform = 11
               
               if (iprint .ge. 3) then
                  write(*, 985) ittype, inform
                  write(10,985) ittype, inform
               end if
               
               return
            else

C              Calculate actual reduction of obhective function

               ared = f - ftrial
               
C              Update the trust-region radius (which may be used)
      
               if (ared .lt. 2.5d-1 * pred) then
                  delta = max(2.5d-1 * deucn, delmin)
                  delta = min(delta, delmax)
               else
                  if ((ared .ge. 0.5d0 * pred) .and.
     +               (deucn .ge. delta - macheps*max(delta,1.0d6))) then
                     delta = max(2.0d0 * delta, delmin)
                     delta = min(delta, delmax)
                  else
                     delta = max(delta, delmin)
                     delta = min(delta, delmax)
                  end if
               end if
               
C              Update x, f and g.
      
               do i = 1, nind
                  x(i) = xtrial(i)
               end do
               
               f = ftrial

               if (gtype .eq. 0) then
                  call calcg(n, nind, ind, x, x, sccol, scol, wd1, g,
     +                 inform)
               else
                  call calcgdiff(n, nind, ind, x, x, sccol, scol, wd1,
     +                 g, macheps, inform)
               end if                   
               neg = neg + 1

               if (inform .lt. 0) then
                  if (iprint .ge. 3) then
                     write(*, 989) ittype, inform
                     write(10,989) ittype, inform
                  end if
                  
                  return
               end if

               inform = 11
               
               if (iprint .ge. 3) then
                  write(*, 985) ittype, inform
                  write(10,985) ittype, inform
               end if
               
               return
            end if
            
         else
            tmp = delmin + rhoms * ((dbound / (1 + sigms)) - delmin)
            delta = max(delmin, tmp)
            delta = min(delta, delmax)
            go to 4
         end if
      end if

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

      call calcf(n, nind, ind, xtrial, x, sccol, scol, wd1, ftrial,
     +     inform)
      nef   = nef + 1
      trnef = trnef + 1
      
      if (inform .lt. 0) then
         if (iprint .ge. 3) then
            write(*, 989) ittype, inform
            write(10,989) ittype, inform
         end if
         
         return
      end if

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

         f = ftrial

         if (gtype .eq. 0) then
            call calcg(n, nind, ind, x, x, sccol, scol, wd1, g, inform)
         else
            call calcgdiff(n, nind, ind, x, x, sccol, scol, wd1, g,
     +           macheps, inform)
         end if  
         neg = neg + 1

         if (inform .lt. 0) then
            if (iprint .ge. 3) then
               write(*, 989) ittype, inform
               write(10,989) ittype, inform
            end if
         else
            inform = 8
            
            if (iprint .ge. 3) then
               write(*, 987) ittype, inform
               write(10,987) ittype, 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

         if (gtype .eq. 0) then
            call calcg(n, nind, ind, x, x, sccol, scol, wd1, g, inform)
         else
            call calcgdiff(n, nind, ind, x, x, sccol, scol, wd1, g,
     +           macheps, inform)
         end if                   
         neg = neg + 1

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

            if (iprint .ge. 3) then
               write(*, 988) ittype, inform
               write(10,988) ittype, inform
            end if
         end if
         
         return
      end if
      
      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) delta, deucn, pred, ared
         write(10,981) delta, deucn, pred, ared
      end if
      
      if (((pred .gt. phieps) .and. (ared .lt. trgamma*pred)) .or. 
     +     ((pred .le. phieps) .and. (f .lt. ftrial))) then
         delta = min(2.5d-1 * deucn, delmax)
         go to 4
      end if
      
C     If extrapolation at step 5 is not to be performed, point xtrial
C     is accepted.

      if (maxextrap .gt. 0) then

         nefprev   = nef
         trexgprev = trexgcnt
         trexbprev = trexbcnt

         amax = -1.0d0

         fprev = f
         
         call extrapolation(n, nind, ind, nind2, ind2, x, l, u, m, meq,
     +        nact, iact, lda, A, b, sccol, scol, f, g, gtype, xtrial,
     +        ftrial, d, wi1, wd3, wd4, lwd4, wd5, tmax, amax, tmp,
     +        rbdlu, rbdli, rbdind, fmin, maxfc, promaxit, projeps,
     +        ceps, macheps, beta, etaext, maxextrap, iprint, wd1, wd2,
     +        nef, neg, trexgcnt, trexbcnt, inform)
         
         if (trexgcnt .gt. trexgprev) then
            trexgfe = trexgfe + (nef - nefprev)
         else if (trexbcnt .gt. trexbprev) then
            trexbfe = trexbfe + (nef - nefprev)
         end if
         
         if (inform .lt. 0) then
            if (iprint .ge. 3) then
               write(*, 989) ittype, inform
               write(10,989) ittype, inform
            end if

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

            return
         elseif (inform .eq. 4) then
            if (iprint .ge. 3) then
               write(*, 988) ittype, inform
               write(10,988) ittype, inform
            end if
            
            return
         elseif (inform .eq. 11) then
            if (iprint .ge. 3) then
               write(*, 985) ittype, inform
               write(10,985) ittype, inform
            end if

            return
         end if

C        Calculate actual reduction of objective function
         
         ared = fprev - f

C        Update the trust-region radius (which may or may not be used)
      
         if (ared .lt. 2.5d-1 * pred) then
            delta = max(2.5d-1 * deucn, delmin)
            delta = min(delta, delmax)
         else
            if ((ared .ge. 0.5d0 * pred) .and.
     +           (deucn .ge. delta - macheps * max(delta, 1.0d6))) then
               delta = max(2.0d0 * delta, delmin)
               delta = min(delta, delmax)
            else
               delta = max(delta, delmin)
               delta = min(delta, delmax)
            end if
         end if
         
         if (inform .eq. 12) then
            inform = 11
            go to 7
         end if

         if (deucn2 .le. macheps) then
            inform = 10
         else
            inform = 0
         end if

         if (iprint .ge. 3) then
            write(*, 982) ittype, inform
            write(10,982) ittype, inform
         end if
         
         return
         
      else
         
         do i = 1, nind
            x(i) = xtrial(i)
         end do

         f = ftrial

         if (gtype .eq. 0) then
            call calcg(n, nind, ind, x, x, sccol, scol, wd1, g, inform)
         else
            call calcgdiff(n, nind, ind, x, x, sccol, scol, wd1, g,
     +           macheps, inform)
         end if
         neg = neg + 1

         if (inform .lt. 0) then
            if (iprint .ge. 3) then
               write(*, 989) ittype, inform
               write(10,989) ittype, inform
            end if
            
            return
         end if

C        Update the trust-region radius (which may or may not be used)
      
         if (ared .lt. 2.5d-1 * pred) then
            delta = max(2.5d-1 * deucn, delmin)
            delta = min(delta, delmax)
         else
            if ((ared .ge. 0.5d0 * pred) .and.
     +           (deucn .ge. delta - macheps * max(delta, 1.0d6))) then
               delta = max(2.0d0 * delta, delmin)
               delta = min(delta, delmax)
            else
               delta = max(delta, delmin)
               delta = min(delta, delmax)
            end if
         end if
         
         if (deucn2 .le. macheps) then
            inform = 10
         else
            inform = 0
         end if
         
         if (iprint .ge. 3) then
            write(*, 982) ittype, inform
            write(10,982) ittype, inform
         end if

         return
      end if
      
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.0d6)) then
            x(ii) = l(ii)
            rbdlu = rbdlu + 1
            rbdind(rbdlu) = ii
         else if (x(ii) .ge. u(ii) - macheps*max(abs(u(ii)),1.0d6)) then
            x(ii) = u(ii)
            rbdlu = rbdlu + 1
            rbdind(rbdlu) = ii + n
         end if
      end do

C     Look to the linear inequality constraints
      
      call expand(n, nind, ind, x)
         
      rbdli = rbdlu
            
      do i = 1, m-nact
         wd5(i) = 0.0d0
      end do

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

      do i = nact+1, m
         ii = iact(i)
         
         if (wd5(i-nact) .le. b(ii) +
     +        macheps * max(abs(b(ii)), 1.0d6)) then
            rbdli = rbdli + 1
            rbdind(rbdli) = i
         end if
      end do
      
      call shrink(n, nind, ind, x)    
      
      if (rbdli .gt. 0) then
         inform = 11
         
         if (iprint .ge. 3) then
            write(*, 985) ittype, inform
            write(10,985) ittype, inform
         end if
      else
         if (iprint .ge. 3) then
            write(*, 982) ittype, inform
            write(10,982) ittype, inform
         end if
      end if
                  
C     Non-executable statements
      
 980  format(/,6x, A4, ' iteration')
 981  format(6x,'delta= ',1PD11.4,' dnorm= ',1PD11.4,' pred= ',1PD11.4,
     +          ' ared= ',1PD11.4)
 982  format(6X, 'Flag of ', A4, '= ',I3,
     +       6X,' (function sufficient decrease)')
 983  format(6X, 'Flag of ', A4, '= ',I3,
     +       6X,' (first-order stationary point close to the boundary)')
 984  format(6x,'Flag of ', A4, '= ',I3,
     +           ' (second-order stationary point)')
 985  format(6x,'Flag of ', A4, '= ',I3,
     +           ' (point on the boundary)')      
 986  format(6x,'Flag of ', A4, '= ',I3,
     +          ' (Too small trust-region radius)')
 987  format(6x,'Flag of ', A4, '= ',I3,
     +          ' (Too many functional evaluations)')
 988  format(6x,'Flag of ', A4, '= ',I3,
     +          ' (Small functional value, smaller than ',/,
     +       6X,'parameter fmin)')
 989  format(6X,'Flag of ', A4, '= ',I3,' Fatal Error')

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

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

      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     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     *****************************************************************

C     This routine performs extrapolation.
C     
C     On Entry
C      
C     n        integer
C              dimension of full space
C
C     nind     integer
C              number of free variables (including the ones used to
C              update QR factorization of Abar)
C
C     ind      integer ind(nind)
C              array which contains, in the first nind positions, the
C              identifiers of the free variables
C
C     nind2    integer
C              number of really free variables
C     
C     ind2     integer ind2(nind)
C              array which contains, in the first nind2 positions, 
C              the indices of ind that contain the real 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     m        integer
C              number of linear constraints
C
C     meq      integer
C              number of equality linear constraints
C     
C     nliact   integer
C              number of linear independent active constraints
C     
C     nact     integer
C              number of linear active constraints
C     
C     iact     integer iact(m)
C              stores the indices of linear active constraints
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(m)
C              right-hand side of linear constraints
C     
C     sccol    logical
C              true iff variables should be scaled
C
C     scol     double precision scol(n)
C              variable scaling factors
C
C     f        double precision
C              function value at x
C
C     g        double precision g(n)
C              gradient at x
C
C     gtype    integer
C              0, if user provided true gradient;
C              1, if gradient is to be approximated
C      
C     xtrial   double precision xtrial(n)
C              trial point xtrial = x + alpha*d
C
C     ftrial   double precision
C              function value at xtrial
C              
C     d        double precision d(nind)
C              descent direction such that xtrial = x + alpha*d 
C     
C     alpha    double precision      
C              scalar such that xtrial = x + alpha*d
C
C     amax     double precision
C              biggest scalar such that xtrial = x + amax*d is feasible.
C              If amax < 0, this routine will calculate amax and gtd
C
C     gtd      double precision
C              g^T d
C      
C     rbdlu    integer
C              number of bounds attained at x + d
C      
C     rbdli    integer
C              rbdli-rbdlu is the number of linear constraints
C              attained at x + d
C      
C     rbdind   integer rbdind(n+m)
C              indeces of variables (or linear constraints) that are
C              satisfied by equality in x + d
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     maxfc    integer
C              maximum allowed number of function evaluations
C
C     promaxit integer
C              maximum allowed number of iterations for projection
C      
C     projeps  double precision
C              error allowed in projection
C
C     ceps     double precision
C              error allowed to consider some point x unfeasible
C              (with respect to linear constaints)
C
C     macheps  double precision
C              macheps is the smallest positive number such that
C              1 + macheps is not equal to 1
C
C     beta     double precision
C              used to decide whether or not extrapolation must be 
C              performed
C
C     etaext   double precision
C              size of extrapolation
C
C
C     maxextrap integer
C              constant to limit the number of extrapolations
C
C     iprint   integer
C              Commands printing. Nothing is printed if iprint is 
C              smaller than 3
C
C     xbext    double precision xbext(n)
C     xtmp     double precision xtmp(n)      
C     wi1      integer wi1(m+n+n)
C     wd1      double precision wd1(n)
C     wd2      double precision wd2(lwd2)
C     bbar     double precision bbar(m)
C              working vectors 
C
C     lwd2     integer
C              size of wd2
C      
C     On Return
C      
C     x        double precision x(n)
C              solution candidate, with inform as described bellow
C
C     f        double precision f
C              function value at x
C
C     g        double precision g(n)
C              gradient at x
C
C     exgcnt   integer
C              number of well-succeeded extrapolations
C
C     exbcnt   integer
C              number of not well-succeeded extrapolations
C
C     nef      integer
C              total number of function evaluations
C
C     neg      integer
C              total number of gradient evaluations
C
C     inform   integer
C              This output parameter tells what happened in this 
C              subroutine, according to the following conventions:
C      
C              0 = successfull termination;
C
C              4 = if maximum allowed number of function evaluations is 
C                  achieved;
C
C              5 = if maximum allowed number of extrapolations is
C                  achieved;
C      
C              8 = the algorithm stopped because the functional value
C                  is very small (f <= fmin);
C
C             11 = if some new constraint is satisfied by equality
C                  because amax is used;
C      
C             12 = if some new constraint is satisfied by equality
C                  because a projection is made;
C      
C            -90 = if an error occurred during function evaluation;
C
C            -92 = if an error occurred during gradient evaluation;

      subroutine extrapolation(n, nind, ind, nind2, ind2, x, l, u, m,
     +     meq, nact, iact, lda, A, b, sccol, scol, f, g, gtype, xtrial,
     +     ftrial, d, wi1, wd1, wd2, lwd2, bbar, alpha, amax, gtd,
     +     rbdlu, rbdli, rbdind, fmin, maxfc, promaxit, projeps, ceps,
     +     macheps, beta, etaext, maxextrap, iprint, xbext, xtmp, nef,
     +     neg, exgcnt, exbcnt, inform)

C     SCALAR ARGUMENTS
      logical sccol
      integer n, nind, nind2, m, meq, nact, gtype, lda, lwd2, rbdlu, 
     +     rbdli, maxfc, promaxit, maxextrap, iprint, nef, neg, exgcnt,
     +     exbcnt, inform
      double precision f, ftrial, alpha, amax, gtd, fmin, projeps, ceps,
     +     macheps, beta, etaext
      
C     ARRAY ARGUMENTS
      integer ind(nind), ind2(nind), iact(m), wi1(m+n+n), rbdind(n+m)
      double precision x(n), l(n), u(n), A(lda,n), b(m), scol(n), g(n),
     +     xtrial(n), wd1(n), wd2(lwd2), bbar(m), d(nind), xbext(n),
     +     xtmp(n)
      
C     LOCAL SCALARS
      integer i, ii, j, jj, jjj, extrap, index, infotmp
      double precision tmp, fbext, ftmp, atmp, gptd, ax, ad
      logical samep

C     Print presentation information

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

      inform = 0
         
C     Calculate amax, which is the biggest positive scalar such that 
C     x + amax*d is still feasible.

      if (amax .lt. 0.0d0) then

         if (alpha .lt. 1.0d0) then
            amax = alpha
         else
            
            amax = 1.0d+30
            rbdlu = 0
            
            do i = 1, nind2
               ii = ind2(i)
               
               if (abs(d(ii)) .ge. macheps * max(abs(x(ii)),1.0d0)) then
                  
                  if (d(ii) .le. 0.0d0) then
                     tmp = (l(ii) - x(ii)) / d(ii)
                     if (tmp .lt. amax - macheps * max(amax,1.0d6)) then
                        amax = tmp
                        rbdlu = 1
                        rbdind(rbdlu) = ii
                     else 
                        if (tmp .le. amax +macheps*max(amax,1.0d6)) then
                           rbdlu = rbdlu + 1
                           rbdind(rbdlu) = ii
                        end if
                     end if
                  else
                     
                     if (d(ii) .ge. 0.0d0) then
                        tmp = (u(ii) - x(ii)) / d(ii)
                        if (tmp .lt. amax -macheps*max(amax,1.0d6)) then
                           amax = tmp
                           rbdlu = 1
                           rbdind(rbdlu) = ii + n
                        else
                           if (tmp .le. amax +
     +                          macheps * max(amax, 1.0d6)) 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
            
            do i = nact+1, m
               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 = bbar(i-nact)
               
               if (abs(ad) .ge. macheps * max(abs(ax), 1.0d0)) then
                  
                  if (ad .le. 0.0d0) then
                     tmp = (b(ii) - ax) / ad
                     
                     if (tmp .lt. amax - macheps * max(amax,1.0d6)) then
                        amax  = tmp
                        rbdlu = 0
                        rbdli = 1
                        rbdind(rbdli) = i
                     else
                        if (tmp .le. amax +macheps*max(amax,1.0d6)) then
                           rbdli = rbdli + 1
                           rbdind(rbdli) = i
                        end if
                     end if
                  end if
               end if
            end do
            
         end if

C        Compute directional derivative
         
         gtd = 0.0d0
         do i = 1, nind
            gtd = gtd + g(i) * d(i)
         end do
         
      end if

C     Evaluate gradient at xtrial

      infotmp = inform
      
      if (gtype .eq. 0) then
         call calcg(n, nind, ind, xtrial, x, sccol, scol, wd1, g,
     +        inform)
      else
         call calcgdiff(n, nind, ind, xtrial, x, sccol, scol, wd1, g,
     +        macheps, inform)
      end if  
      neg = neg + 1

      if (inform .lt. 0) then               
         if (iprint .ge. 3) then
            write(*, 987) inform
            write(10,987) inform
         end if
         
         return               
      end if
      
      inform = infotmp
      
      gptd = 0.0d0
      do i = 1, nind
         gptd = gptd + g(i) * d(i)
      end do
      
C     Verify directional derivative (beta condition)
      
      if (gptd .ge. beta * gtd) then

C        Finish the extrapolation with the current point

         f = ftrial
         
         do i = 1, nind
            x(i) = xtrial(i)
         end do

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

         if (iprint .ge. 3) then
            write(*, 982) inform
            write(10,982) inform
         end if
         
         return
      end if
      
C     f and x before extrapolation
      fbext = ftrial
      
      do i = 1, nind
         xbext(i) = xtrial(i)
      end do
      
      extrap = 0
      
C     Test if the maximum number of extrapolations was exceeded

 100  if (extrap .ge. maxextrap) then

C        Finish the extrapolation with the current point

         f = ftrial
         
         do i = 1, nind
            x(i) = xtrial(i)
         end do

C        When projection was performed, expand columns of A.
         
         if (inform .eq. 12) then
            call expandcol(nind, m, nind2, ind2, lda, A)
            call expandcol(n, m, nind, ind, lda, A)
         end if
         
C        If extrap=0 the gradient was computed for testing the beta
C        condition and it is not necessary to compute it again

         if (extrap .ne. 0) then

            infotmp = inform
            
            if (gtype .eq. 0) then
               call calcg(n, nind, ind, x, x, sccol, scol, wd1, g,
     +              inform)
            else
               call calcgdiff(n, nind, ind, x, x, sccol, scol, wd1, g,
     +              macheps, inform)
            end if 
            neg = neg + 1
            
            if (inform .lt. 0) then               
               if (iprint .ge. 3) then
                  write(*, 987) inform
                  write(10,987) inform
               end if
               
               return
            end if

            inform = infotmp
            
            if (f .lt. fbext) then
               exgcnt = exgcnt + 1
            else
               exbcnt = exbcnt + 1
            end if
            
         end if
         
         if ((inform .ne. 11) .and. (inform .ne. 12)) then
            inform = 0
         end if
         
         if (iprint .ge. 3) then
            write(*, 985) inform
            write(10,985) inform
         end if
         
         return
         
      end if
      
C     Chose new step 

      if ((alpha .lt. amax) .and. (etaext * alpha .gt. amax)) then
         atmp   = amax
         inform = 11
      else
         atmp = etaext * alpha
      end if

C     Compute new trial point

      do i = 1, nind
         xtmp(i) = x(i) + atmp * d(i)
      end do

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

C     Project

      if (atmp .gt. amax) then

         if (inform .ne. 12) 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 = meq+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 = meq+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 = 1, nact
               iact(i) = i
            end do
            
            do i = nact+1, m
               iact(i) = m + nact + 1 - i
            end do

C           Shrink columns of A (like x).
         
            call shrinkcol(n, m, nind, ind, lda, A)

C           Complete xtmp with last components of x.

            do i = nind+1, n
               xtmp(i) = x(i)
            end do
         
C           Shrink xtmp, l, u, A to the space of really free variable
C           (using nind2 and ind2).

            call shrink(nind, nind2, ind2, xtmp)
            call shrink(nind, nind2, ind2, l)
            call shrink(nind, nind2, ind2, u)
            call shrinkcol(nind, m, nind2, ind2, lda, A)

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, m
               bbar(i) = b(i)
            end do
            
            do j = nind2+1, n
               do i = 1, m
                  bbar(i) = bbar(i) - A(i,j) * xtmp(j)
               end do
            end do
            
         else
            
C           Shrink xtmp, l, u, A to the space of really free variable
C           (using nind2 and ind2).
            
            call shrink(nind, nind2, ind2, xtmp)
            call shrink(nind, nind2, ind2, l)
            call shrink(nind, nind2, ind2, u)
         end if
            
C        Project.

         infotmp = inform
         
         call project(nind2, xtmp, l, u, m, nact, lda, A, bbar,
     +        promaxit, projeps, wi1, wd1, wd2, lwd2, inform)

         if (inform .ne. 0) then

            inform = infotmp
            
C           Check if the solution is feasible.
         
            do i = 1, nind2
               if (xtmp(i) .lt. l(i) -macheps*max(abs(l(i)),1.0d6)) then
                  go to 10
               end if

               if (xtmp(i) .gt. u(i) +macheps*max(abs(u(i)),1.0d6)) then
                  go to 10
               end if
            end do
                        
            do i = 1, m
               wd2(i) = 0.0d0
            end do
            
            do j = 1, nind2
               do i = 1, m
                  wd2(i) = wd2(i) + A(i,j) * xtmp(j)
               end do
            end do
            
            do i = 1, meq
               if (abs(wd2(i) - bbar(i)) .gt. ceps) then
                  go to 10
               end if
            end do
            
            do i = meq+1, m
               if (bbar(i) - wd2(i) .gt. ceps) then
                  go to 10
               end if
            end do
            
            go to 20

C           Expand x, l, u to the space of free variable (given by nind2
C           and ind2).

 10         call expand(nind, nind2, ind2, xtmp)
            call expand(nind, nind2, ind2, l)
            call expand(nind, nind2, ind2, u)
            
C           When projection was performed, expand columns of A.
            
            call expandcol(nind, m, nind2, ind2, lda, A)
            call expandcol(n, m, nind, ind, lda, A)

C           Finish the extrapolation with the current point
            
            f = ftrial
            
            do i = 1, nind
               x(i) = xtrial(i)
            end do
            
C           If extrap=0 the gradient was computed for testing the
C           beta condition and it is not necessary to compute it again
            
            if (extrap .ne. 0) then
               
               infotmp = inform
               
               if (gtype .eq. 0) then
                  call calcg(n, nind, ind, x, x, sccol, scol, wd1, g,
     +                 inform)
               else
                  call calcgdiff(n, nind, ind, x, x, sccol, scol, wd1,
     +                 g, macheps, inform)
               end if
               neg = neg + 1
               
               if (inform .lt. 0) then                  
                  if (iprint .ge. 3) then
                     write(*, 987) inform
                     write(10,987) inform
                  end if
                  
                  return                 
               end if
               
               inform = infotmp
               
               if (f .lt. fbext) then
                  exgcnt = exgcnt + 1
               else
                  exbcnt = exbcnt + 1
               end if
               
            end if
            
            if (iprint .ge. 3) then
               write(*, 989) inform
               write(10,989) inform
            end if
               
            return
         end if

C        Expand x, l, u to the space of free variable (given by nind2
C        and ind2).

 20      call expand(nind, nind2, ind2, xtmp)
         call expand(nind, nind2, ind2, l)
         call expand(nind, nind2, ind2, u)
         
         inform = 12
         
      end if

C     Test if this is not the same point as the previous one.
C     This test is performed only when alpha > amax.

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

         if (samep) then

C           Finish the extrapolation with the current point
            
            f = ftrial

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

C           When projection was performed, expand columns of A.
         
            if (inform .eq. 12) then
               call expandcol(nind, m, nind2, ind2, lda, A)
               call expandcol(n, m, nind, ind, lda, A)
            end if            
            
C           If extrap=0 the gradient was computed for testing the
C           beta condition and it is not necessary to compute it again

            if (extrap .ne. 0) then

               infotmp = inform
               
               if (gtype .eq. 0) then
                  call calcg(n, nind, ind, x, x, sccol, scol, wd1, g,
     +                 inform)
               else
                  call calcgdiff(n, nind, ind, x, x, sccol, scol, wd1,
     +                 g, macheps, inform)
               end if
               neg = neg + 1
               
               if (inform .lt. 0) then                  
                  if (iprint .ge. 3) then
                     write(*, 987) inform
                     write(10,987) inform
                  end if
                  
                  return                 
               end if

               inform = infotmp
               
               if (f .lt. fbext) then
                  exgcnt = exgcnt + 1
               else
                  exbcnt = exbcnt + 1
               end if
               
            end if

            if ((inform .ne. 11) .and. (inform .ne. 12)) then
               inform = 0
            end if
            
            if (iprint .ge. 3) then
               write(*, 983) inform
               write(10,983) inform
            end if
            
            return
            
         end if
         
      end if

C     Evaluate function

      infotmp = inform
      
      call calcf(n, nind, ind, xtmp, x, sccol, scol, wd1, ftmp, inform)
      nef   = nef + 1
      
      if (inform .lt. 0) then

C        If the objective function is not well defined in an 
C        extrapolated point, we discard all the extrapolated points
C        and return to a safe region (where the point before
C        starting the extrapolations is)

         f = fbext
         
         do i = 1, nind
            x(i) = xbext(i)
         end do

C        When projection was performed, expand columns of A.
         
         if (infotmp .eq. 12) then
            call expandcol(nind, m, nind2, ind2, lda, A)
            call expandcol(n, m, nind, ind, lda, A)
         end if
         
C        If extrap=0 the gradient was computed for testing the beta
C        condition and it is not necessary to compute it again

         if (extrap .ne. 0) then

            if (gtype .eq. 0) then
               call calcg(n, nind, ind, x, x, sccol, scol, wd1, g,
     +              inform)
            else
               call calcgdiff(n, nind, ind, x, x, sccol, scol, wd1, g,
     +              macheps, inform)
            end if
            neg = neg + 1
                        
            if (inform .lt. 0) then
               if (iprint .ge. 3) then
                  write(*, 987) inform
                  write(10,987) inform
               end if
               
               return
               
            end if
            
            exbcnt = exbcnt + 1
            
         end if

         inform = infotmp
         
         if ((inform .ne. 11) .and. (inform .ne. 12)) then
            inform = 0
         end if
         
         if (iprint .ge. 3) then
            write(*, 988) inform
            write(10,988) inform
         end if
         
         return
         
      end if

      inform = infotmp

C     Test f going to -inf

      if (ftrial .le. fmin) then

C        Finish the extrapolation with the current point

         f = ftrial

         do i = 1, nind
            x(i) = xtrial(i)
         end do
         
C        When projection was performed, expand columns of A.
         
         if (inform .eq. 12) then
            call expandcol(nind, m, nind2, ind2, lda, A)
            call expandcol(n, m, nind, ind, lda, A)
         end if

C        If extrap=0 the gradient was computed for testing the beta
C        condition and it is not necessary to compute it again

         if (extrap .ne. 0) then

            infotmp = inform
            
            if (gtype .eq. 0) then
               call calcg(n, nind, ind, x, x, sccol, scol, wd1, g,
     +              inform)
            else
               call calcgdiff(n, nind, ind, x, x, sccol, scol, wd1, g,
     +              macheps, inform)
            end if  
            neg = neg + 1
            
            if (inform .lt. 0) then               
               if (iprint .ge. 3) then
                  write(*, 987) inform
                  write(10,987) inform
               end if
               
               return               
            end if
            
            inform = infotmp
            
            if (f .lt. fbext) then
               exgcnt = exgcnt + 1
            else
               exbcnt = exbcnt + 1
            end if
            
         end if
         
         inform = 4
         
         if (iprint .ge. 3) then
            write(*, 984) inform
            write(10,984) inform
         end if

         return
         
      end if
           
C     Test maximum number of functional evaluations
      
      if (nef .ge. maxfc) then

C        Finish the extrapolation with the current point
         
         f = ftrial

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

C        When projection was performed, expand columns of A.
         
         if (inform .eq. 12) then
            call expandcol(nind, m, nind2, ind2, lda, A)
            call expandcol(n, m, nind, ind, lda, A)
         end if
         
C        If extrap=0 the gradient was computed for testing the beta
C        condition and it is not necessary to compute it again
         
         if (extrap .ne. 0) then

            infotmp = inform
            
            if (gtype .eq. 0) then
               call calcg(n, nind, ind, x, x, sccol, scol, wd1, g,
     +              inform)
            else
               call calcgdiff(n, nind, ind, x, x, sccol, scol, wd1, g,
     +              macheps, inform)
            end if
            neg = neg + 1

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

            inform = infotmp
            
            if (f .lt. fbext) then
               exgcnt = exgcnt + 1
            else
               exbcnt = exbcnt + 1
            end if
         end if

         inform = 8

         if (iprint .ge. 3) then
            write(*, 986) inform
            write(10,986) inform
         end if
         
         return
         
      end if
      
C     Print information of this iteration

      if (iprint .ge. 3) then
         write(*, 981) atmp, ftmp, nef
         write(10,981) atmp, ftmp, nef
      end if

C     If the functional value decreases then set the current point and 
C     continue the extrapolation

      if (ftmp .lt. ftrial) then
         
         alpha  = atmp
         ftrial = ftmp
         
         do i = 1, nind
            xtrial(i) = xtmp(i)
         end do
         
         extrap = extrap + 1
         
         go to 100

C     If the functional value does not decrease then discard the last 
C     trial and finish the extrapolation with the previous point

      else

         f = ftrial
         
         do i = 1, nind
            x(i) = xtrial(i)
         end do

C        When projection was performed, expand columns of A.
         
         if (inform .eq. 12) then
            call expandcol(nind, m, nind2, ind2, lda, A)
            call expandcol(n, m, nind, ind, lda, A)
         end if
         
C        If extrap=0 the gradient was computed for testing the beta
C        condition and it is not necessary to compute it again

         if (extrap .ne. 0) then

            infotmp = inform
            
            if (gtype .eq. 0) then
               call calcg(n, nind, ind, x, x, sccol, scol, wd1, g,
     +              inform)
            else
               call calcgdiff(n, nind, ind, x, x, sccol, scol, wd1, g,
     +              macheps, inform)
            end if
            neg = neg + 1
            
            if (inform .lt. 0) then
               
               if (iprint .ge. 3) then
                  write(*, 987) inform
                  write(10,987) inform
               end if
               
               return
            end if

            inform = infotmp
            
            if (f .lt. fbext) then
               exgcnt = exgcnt + 1
            else
               exbcnt = exbcnt + 1
            end if
            
         end if

         if ((inform .ne. 11) .and. (inform .ne. 12)) then
            inform = 0
         end if
         
         if (iprint .ge.3) then
            write(*, 983) inform
            write(10,983) inform
         end if
         
         return
         
      end if

 980  format(6X,'Extrapolation')
 981  format(6X,'Alpha= ',1PD11.4,' F= ',1PD11.4,' FE= ',I5)
 982  format(6X,'Flag of Extrapolation = ',I3,
     +          ' (beta-condition holds. No extrapolation is done. )')      
 983  format(6X,'Flag of Extrapolation = ',I3,
     +          ' (Armijo-like criterion satisfied)')
 984  format(6X,'Flag of Extrapolation = ',I3,
     +          ' (Small functional value, smaller than ',/,
     +       6X,'parameter fmin)')
 985  format(6X,'Flag of Extrapolation = ',I3,
     +          ' (Too many extrapolations)')
 986  format(6X,'Flag of Extrapolation = ',I3,
     +          ' (Too many functional evaluations)')
 987  format(6X,'Flag of Extrapolation = ',I3,' Fatal Error')
 988  format(6X,'Flag of Extrapolation = ',I3,
     +          ' (Fatal Error in an extrapolated point)')
 989  format(6X,'Flag of Extrapolation = ',I3,
     +          ' (Error in projection. Last point is used)')
      
      end

C     ******************************************************************
C     ******************************************************************
      
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 \lamms 
C     that is a zero of the function
C
C     phi(\lamms) = 1/||p|| - 1/delta,
C      
C     where p is the solution of the linear system
C
C     (B + \lamms 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              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              Commands printing. Nothing is printed if iprint is 
C              smaller than 3
C
C     t        double precision t(n)
C     z        double precision z(n)
C     wd       double precision wd(n)
C              working vectors
C
C     l        double precision
C              initial value for lamms
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     nch      integer
C              number of Cholesky decompositions
C
C     inform   integer
C              stores which convergence criteria was satisfied:
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              4 = maximum allowed number of iterations is achieved;      
C     
C             <0 = error

      subroutine MEQB(n, g, ldb, B, diag, delta, sigma1, sigma2, eps,
     +     macheps, maxit, iprint, t, z, wd, l, p, nch, inform)

C     SCALAR ARGUMENTS
      integer n, ldb, maxit, iprint, nch, 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), wd(n), p(n)
      
C     LOCAL SCALARS
      logical pd
      integer i, j, sgn, idx, nit
      double precision ll, lu, ls, teucn2, peunc, peunc2, geucn, b1n,
     +     tmp, d, ueucn2, rpeucn2, rzeucn2, tau, ptz, delta2
      
      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     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)
      
      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

      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 ((ll .le. macheps) .and. (lu .le. macheps) .and. 
     +     (abs(ls) .le. macheps)) then
         inform = 0
         go to 21
      end if

C     step 4: initialize iteration counter

      nit = 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) 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)
      nch = nch + 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) nit
            write(*, 981) ls, ll, lu, l
            write(*, 988)
 
            write(10,980) nit
            write(10,981) ls, ll, lu, l
            write(10,988) 
         end if
         
         call calcU(n, idx, ldb, B, p, ueucn2)
         ll = max(l, ll)
         ls = max(l + (d / ueucn2), ls)
         ll = max(ll, ls)
         l = ls
         nit = nit + 1

C        Test whether the number of iterations is exhausted

         if (nit .ge. maxit) then
            inform = 5
            
            if (iprint .ge. 3) then
               write(*, 989) inform, maxit
               write(10,989) inform, maxit
            end if
            
            go to 21
         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, rpeucn2)

      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, 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 product of matrix R by the vector z

         do i = 1, n
            wd(i) = 0.0d0
         end do
         
         do j = 1, n
            do i = 1, j
               wd(i) = wd(i) + B(i,j) * z(j)
            end do
         end do
         
C        Calculate the squared Euclidian-norm of the product Rz

         rzeucn2 = 0.0d0
         do i = 1, n
            rzeucn2 = rzeucn2 + wd(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
         else
            sgn = 1
         end if
         
         tmp = delta2 - peunc2

         tau = (ptz**2) + tmp
         tau = tmp / (ptz + sgn * dsqrt(tau))         
 
      end if

C     Print informations (current iteration)

      if (iprint .ge. 3) then
         write(*, 980) nit
         write(*, 981) ls, ll, lu, l
         write(*, 982) peunc

         write(10,980) nit
         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

      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. ((tau*tau*rzeucn2 .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 .eq. ll) .and. (ls .le. ll))) then 

C        Solve R^Tt = p for t

         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

C        Calculate t squared Euclidian-norm
         
         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

      nit = nit + 1

C     Test whether the number of iterations is exhausted
      
      if (nit .ge. maxit) then
         inform = 5
         
         if (iprint .ge. 3) then
            write(*, 989) inform, maxit
            write(10,989) inform, maxit
         end if
         
         go to 21
      end if
      
C     step 23: start a new iteration

      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) nit
         write(*, 981) ls, ll, lu, l
         write(*, 987) inform
         write(*, 984) peunc
         write(*, 985) delta

         write(10,986) nit
         write(10,981) ls, ll, lu, l
         write(10,987) inform
         write(10,984) peunc
         write(10,985) delta
      end if

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 was exceeded the maximum allowed number of iterations',
     +       6X,'(maxit=',I7,')') 

      end

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

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

      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     LOCAL SCALARS
      integer i, j, k
      double precision sum

      do j = 1, n
         do i = j, n
            if (i .eq. j) then
               sum = diag(j) + l
            else
               sum = B(i,j)
            end if
            
            do k = j - 1, 1, -1
               sum = sum - B(k,j) * B(k,i)
            end do

            if (i .eq. j) then
               if (sum .le. 0.0d0) then
                  d = - sum
                  idx = j
                  pd = .false.
                  return
               else if (sum .le. macheps) then
                  d = macheps
                  idx = j
                  pd = .false.
                  return
               else 
                  B(j,j) = dsqrt(sum)
               end if
            else 
               B(j,i) = sum / B(j,j)
            end if
         end do
      end do
      pd = .true.
      end

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

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              vector
C
C     On Return
C     
C     x        double precision x(n)
C              system solution
C
C     yeucn2   double precision
C              y squared Euclidian-norm, where y = Rx

      subroutine solveSys(n, lda, A, b, x, yeucn2)

C     SCALAR ARGUMENTS
      integer n, lda
      double precision yeucn2
      
C     ARRAY ARGUMENTS
      double precision A(lda,n), b(n), x(n)

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
      
      yeucn2 = 0.0d0
      do i = 1, n
         yeucn2 = yeucn2 + x(i)**2
      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     ******************************************************************

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 n positions with u(k) = 1 and u(j) = 0, for j > k.
C
C     On Entry
C      
C     n        integer
C              dimension of A
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,n)
C              upper triangular matrix
C
C     On Return
C      
C     u        double precision u(n)
C              system solution
C
C     ueucn2   double precision
C              u squared Euclidian-norm

      subroutine calcU(n, k, lda, A, u, ueucn2)

C     SCALAR ARGUMENTS
      integer n, k, lda
      double precision ueucn2
      
C     ARRAY ARGUMENTS
      double precision A(lda,n), u(n)

C     LOCAL SCALARS
      integer i, j

      do i = 1, k-1
         u(i) = -A(i,k)
      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

      ueucn2 = 0.0d0
      do i = 1, k
         ueucn2 = ueucn2 + u(i)**2
      end do

      end

C     ******************************************************************
C     ******************************************************************      
      
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 (\lamms_1). 
C     In this technique, when \lamms approaches -\lamms_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              \lamms_1

      subroutine calcZ(n, ldr, R, z)

C     SCALAR ARGUMENTS
      integer ldr, n

C     ARRAY ARGUMENTS
      double precision R(ldr,n), z(n)

C     LOCAL SCALARS
      double precision w, wk, wkm, ek
      double precision s, sm
      integer i, k
      
      ek = 1.0d0
      
      do i = 1, n
         z(i) = 0.0d0
      end do
      
      do k = 1, n
         if (z(k) .ne. 0.0d0) then
            ek = dsign(ek,-z(k))
         end if
         
         if (abs(ek-z(k)) .gt. abs(R(k,k))) then
            s = abs(R(k,k)) / 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 (R(k,k) .eq. 0.0d0) then 
            wk = 1
            wkm = 1
         else
            wk = wk / R(k,k)
            wkm = wkm / R(k,k)
         end if
         
         if (k .eq. n) then
            go to 10
         end if
         
         do i = k+1, n
            sm = sm + abs(z(i) + wkm * R(k,i))
            z(i) = z(i) + wk * R(k,i)
            s = s + abs(z(i))
         end do
         
         if (s .lt. sm) then
            w = wkm - wk
            wk = wkm
            
            do i = k+1, n
               z(i) = z(i) + w * R(k,i)
            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     ******************************************************************

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     m        integer
C              total number of linear constraints (excluding bounds)
C
C     meq      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(m)
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     wi1      integer wi(n+m+m)
C     wd1      double precision wd1(n)
C     wd2      double precision wd2(lwd2)
C              working vectors
C      
C     lwd2     integer
C              length of wd2. Must be set to, at least, 1.5*n*n+10*n+m
C     
C     On Return
C      
C     x        double precision x(n)
C              projected vector
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, maximum number of iterations attained;
C
C              2, accuracy is insuffient to maintain increasing function
C                 values;
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
      
      subroutine project(n, x, l, u, m, meq, lda, A, b, maxit, eps, wi1,
     +     wd1, wd2, lwd2, inform)

C     SCALAR ARGUMENTS     
      integer n, m, meq, lda, maxit, lwd2, inform
      double precision eps
      
C     ARRAY ARGUMENTS
      integer wi1(m+n+n)
      double precision x(n), l(n), u(n), A(lda,n), b(m), wd1(n),
     +     wd2(lwd2)
      
C     LOCAL SCALARS
      integer i, nact

C     If there are only bound constraints, there no need to call the
C     quadratic programming solver.
      
      if (m .eq. 0) then
         do i = 1, n
            if (x(i) .lt. l(i)) then
               x(i) = l(i)
            else if (x(i) .gt. u(i)) then
               x(i) = u(i)
            end if
         end do

         return
      end if
      
C     Call the quadratic programming solver.

      do i = 1, n
         wd1(i) = -x(i)
      end do
      
      call QL00022(n, m, meq, lda, m+n, A, b, wd1, l, u, x, nact, wi1,
     +     maxit, eps, inform, wd2, lwd2)

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

C     Reduct point x from space of dimension n to a space of dimension 
C     nind (space of free variables). To do so, in the first nind
C     components of x are stored the values corresponding to the free
C     variables and in the last n - nind components are stored the
C     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     x        double precision x(n)
C              point to be reduced to a space of smaller dimension 
C              (reduced space)
C     
C     On Return
C      
C     x        double precision x(n)
C              point reduced to a space of smaller dimension (reduced
C              space). The first nind positions store the free 
C              variable values and the last n - nind store the fixed 
C              variable values

      subroutine shrink(n, nind, ind, x)

C     SCALAR ARGUMENTS       
      integer n, nind

C     ARRAY ARGUMENTS       
      integer ind(nind)
      double precision x(n)

C     LOCAL SCALARS      
      integer i, ii
      double precision tmp

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

      end

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

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

      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     LOCAL SCALARS      
      integer i, j, jj
      double precision tmp

      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     *****************************************************************      

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

      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     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     *****************************************************************      

C     Expand point x from space of dimension nind to space of dimension n.
C     This is done by rearranging vector x so it is exactly the way it
C     was before using the subroutine shrink.
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     x        double precision x(n)
C              point to be expanded to a space of higher dimension 
C              (full space)
C
C     On Return
C      
C     x        double precision x(n)
C              point expanded to a space of higher dimension 
C              (full space)

      subroutine expand(n, nind, ind, x)

C     SCALAR ARGUMENTS       
      integer n, nind
      
C     ARRAY ARGUMENTS 
      integer ind(nind)
      double precision x(n)

C     LOCAL SCALARS
      integer i, ii
      double precision tmp

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

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

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)
      
      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     LOCAL SCALARS
      integer i, j, jj
      double precision tmp

      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     *****************************************************************
      
C     Evaluate objective function at x. Because x is in the reduced 
C     space, it is not possible to simply call subroutine evalf. It is 
C     necessary to copy to the end of x the values of the n - nind fixed 
C     variables (which are in the last n - nind positions of xc), 
C     rearrange vector x so it is in the full space, use subroutine 
C     evalf and then shrink x back.
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     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     sccol    logical
C              true iff variables should be scaled
C
C     scol     double precision scol(n)
C              variable scaling factors
C     
C     wd       double precision wd(n) 
C              working vector
C      
C     On Return
C      
C     fx       double precision
C              function value evaluated at x
C
C     inform   integer
C              0, if no problem occurs;
C             <0, otherwise

      subroutine calcf(n, nind, ind, x, xc, sccol, scol, wd, fx, inform)

C     SCALAR ARGUMENTS
      logical sccol
      integer n, nind, inform
      double precision fx
      
C     ARRAY ARGUMENTS             
      integer ind(nind)
      double precision x(n), xc(n), scol(n), wd(n)

C     LOCAL SCALARS      
      integer i

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

      call expand(n, nind, ind, x)

      if (sccol) then
         do i = 1, n
            wd(i) = scol(i) * x(i)
         end do
         call evalfb(n, wd, fx, inform)
      else
         call evalfb(n, x, fx, inform)
      end if
      
      call shrink(n, nind, ind, x)

      end

C     *****************************************************************
C     *****************************************************************
      
C     Evaluate gradient at x. Because x is in the reduced space, it is 
C     not possible to simply call subroutine evalg. It is necessary to 
C     copy to the end of x the values of the n - nind fixed variables 
C     (which are in the last n - nind positions of xc), rearrange vector  
C     x so it is in the full space, use subroutine evalg and then shrink 
C     both x and g (so both are in the reduced space).
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     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     sccol    logical
C              true iff variables should be scaled
C
C     scol     double precision scol(n)
C              variable scaling factors
C      
C     wd       double precision wd(n)
C              working vector
C      
C     On Return
C      
C     g        double precision g(n)
C              function gradient evaluated at x in the reduced space
C
C     inform   integer
C              0, if no problem occurs;
C             <0, otherwise
      
      subroutine calcg(n, nind, ind, x, xc, sccol, scol, wd, g, inform)

C     SCALAR ARGUMENTS
      logical sccol
      integer n, nind, inform

C     ARRAY ARGUMENTS
      integer ind(nind)
      double precision x(n), xc(n), scol(n), wd(n), g(n)
      
C     LOCAL SCALARS
      integer i

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

      call expand(n, nind, ind, x)

      if (sccol) then
         do i = 1, n
            wd(i) = x(i) * scol(i)
         end do
         call evalgb(n, wd, g, inform)
         do i = 1, n
            g(i) = g(i) * scol(i)
         end do
      else
         call evalgb(n, x, g, inform)
      end if
      
      call shrink(n, nind, ind, x)
      call shrink(n, nind, ind, g)

c---  >      
      do i = 1, nind
         if (.not. ((g(i) .ge. -1.0d+99) .or. (g(i) .le. 1.0d+99))) then
            inform = -99
         end if
      end do
c---  >
      
      end

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

C     Approximates the gradient vector g(x) of the objective function by 
C     central finite differences. This subroutine, which works in the 
C     full space, is prepared to replace the subroutine evalg (to 
C     evaluate the gradient vector) in the case of the lastest have not
C     being provided by the user.
C
C     On Entry
C
C     n        integer
C              number of variables
C     
C     x        double precision x(n)
C              current point
C
C     macheps  double precision
C              machine epsilon
C
C     On Return
C
C     g        double precision g(n)
C              approximation of the gradient vector at x
C
C     inform   integer
C              0 = no errors,
C            -92 = there was an error in the gradient calculation.
      
      subroutine evalgdiff(n, x, g, macheps, inform)

C     SCALAR ARGUMENTS
      integer n, inform
      double precision macheps
      
C     ARRAY ARGUMENTS
      double precision x(n), g(n)

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

      inform = 0
      
      do j = 1, n
         tmp  = x(j)
         
         step = macheps**(1.0d0/3.0d0) * max(abs(tmp), 1.0d0)
         
         x(j) = tmp + step

         call evalfb(n, x, fplus, inform)
         
         if (inform .lt. 0) then
            inform = -92
            return
         end if
         
         x(j) = tmp - step

         call evalfb(n, x, fminus, inform)
         
         if (inform .lt. 0) then
            inform = -92
            return
         end if
         
         g(j) = (fplus - fminus) / (2.0d0 * step)
         x(j) = tmp
      end do
      
      end
      
C     *****************************************************************
C     *****************************************************************
      
C     Evaluate gradient at x. Because x is in the reduced space, it is 
C     not possible to simply call subroutine evalg. It is necessary to 
C     copy to the end of x the values of the n - nind fixed variables 
C     (which are in the last n - nind positions of xc), rearrange vector  
C     x so it is in the full space, use subroutine evalg and then shrink 
C     both x and g (so both are in the reduced space).
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     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     sccol    logical
C              true iff variables should be scaled
C
C     scol     double precision scol(n)
C              variable scaling factors
C      
C     wd       double precision wd(n)
C              working vector
C      
C     macheps  double precicion
C              machine epsilon
C      
C     On Return
C      
C     g        double precision g(n)
C              function gradient evaluated at x in the reduced space
C
C     inform   integer
C              0, if no problem occurs;
C             <0, otherwise
      
      subroutine calcgdiff(n, nind, ind, x, xc, sccol, scol, wd, g,
     +     macheps, inform)

C     SCALAR ARGUMENTS
      logical sccol
      integer n, nind, inform
      double precision macheps
      
C     ARRAY ARGUMENTS
      integer ind(nind)
      double precision x(n), xc(n), scol(n), wd(n), g(n)
      
C     LOCAL SCALARS
      integer i

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

      call expand(n, nind, ind, x)

      if (sccol) then
         do i = 1, n
            wd(i) = x(i) * scol(i)
         end do
         call evalgdiff(n, wd, g, macheps, inform)
         do i = 1, n
            g(i) = g(i) * scol(i)
         end do
      else
         call evalgdiff(n, x, g, macheps, inform)
      end if
      
      call shrink(n, nind, ind, x)
      call shrink(n, nind, ind, g)

      end      
      
C     *****************************************************************
C     *****************************************************************
      
C     Evaluate Hessian at x. Because x is in the reduced space, it is 
C     not possible to simply call subroutine evalh. It is necessary to 
C     copy to the end of x the values of the n - nind fixed variables 
C     (which are in the last n - nind positions of xc), rearrange vector  
C     x so it is in the full space, use subroutine evalh and then shrink 
C     x (so it is in the reduced space).
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     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     sccol    logical
C              true iff variables should be scaled
C
C     scol     double precision scol(n)
C              variable scaling factors
C      
C     wd       double precision wd(n)
C              working vector
C      
C     ldh      integer
C              leading dimension of H
C      
C     On Return
C      
C     H        double precision H(ldh,n)
C              function gradient evaluated at x in the reduced space
C
C     inform   integer
C              0, if no problem occurs;
C             <0, otherwise
      
      subroutine calch(n, nind, ind, x, xc, sccol, scol, wd, ldh, H,
     +     inform)

C     SCALAR ARGUMENTS
      logical sccol
      integer n, nind, ldh, inform

C     ARRAY ARGUMENTS
      integer ind(nind)
      double precision x(n), xc(n), scol(n), wd(n), H(ldh,n)
      
C     LOCAL SCALARS
      integer i, j

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

      call expand(n, nind, ind, x)

      if (sccol) then
         do i = 1, n
            wd(i) = x(i) * scol(i)
         end do

         call evalhb(n, wd, ldh, H, inform)

         do j = 1, n
            do i = j, n
               H(i,j) = H(i,j) * scol(i) * scol(j)
            end do
         end do
      else
         call evalhb(n, x, ldh, H, inform)
      end if
      
      call shrink(n, nind, ind, x)
      
      end

C     *****************************************************************
C     *****************************************************************
      
C     Evaluate reduced Hessian at x. Because x is in the reduced space
C     of free variables, it is not possible to simply call subroutine
C     evalh. It is necessary to copy to the end of x the values of the
C     n - nind fixed variables (which are in the last n - nind
C     positions of xc), rearrange vector x so it is in the full space,
C     use subroutine evalh and shrink both x and H (so both are in the
C     reduced space of free variables). Then, calculate H = Z^T H Z.
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     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     sccol    logical
C              true iff variables should be scaled
C
C     scol     double precision scol(n)
C              variable scaling factors
C      
C     nliact   integer
C              number of active linear independent linear constraints
C
C     ldabar   integer
C              leading dimension of matrix Abar
C
C     Abar     double precision Abar(ldabar,nliact)
C              matrix that constains QR factorization of linear
C              constraints. Used to calculate Z
C
C     tau      double precision tau(nliact)
C              used in factorization of Abar. Used to calculate Z
C
C     macheps  double precicion
C              machine epsilon
C            
C     wd1      double precision wd1(n)
C     wd2      double precision wd2(n)
C     wd3      double precision 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 of H
C      
C     inform   integer
C              0, if no problem occurs;
C             <0, otherwise
      
      subroutine calchz(n, nind, ind, x, xc, sccol, scol, nliact,
     +     ldabar, Abar, tau, macheps, wd1, wd2, wd3, ldh, H, diag,
     +     inform)

C     SCALAR ARGUMENTS
      logical sccol
      integer n, nind, nliact, ldabar, ldh, inform
      double precision macheps
      
C     ARRAY ARGUMENTS
      integer ind(nind)
      double precision x(n), xc(n), scol(n), Abar(ldabar,nliact),
     +     tau(nliact), wd1(n), wd2(n), wd3(n), H(ldh,n),
     +     diag(nind-nliact)
      
C     LOCAL SCALARS
      integer i, j

      do i = nind+1, n
         x(i) = xc(i)
      end do
      
      call expand(n, nind, ind, x)
      
      if (sccol) then
         do i = 1, n
            wd1(i) = x(i) * scol(i)
         end do
         
         call evalhb(n, wd1, ldh, H, inform)
         
         do j = 1, n
            do i = j, n
               H(i,j) = H(i,j) * scol(i) * scol(j)
            end do
         end do
      else
         call evalhb(n, x, ldh, H, inform)
      end if

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

      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
      
      do i = 1, nind-nliact
         diag(i) = H(i,i)
      end do
      
      end
      
C     *****************************************************************
C     *****************************************************************
      
C     Evaluate projected Hessian (Z^T H Z) times vector d (step in the
C     null space of linear equality constraints).
C     First, calculate w = Z d. This is the step in the reduced space of
C     free variables. Then, whenever a variable of index i is fixed,
C     d(i) must be set to 0. After this, calculate w2 = H w. Then vector
C     w2 is reduced to the space of free variables and calculate
C     w3 = Z^T w2.
C
C     On Entry
C     
C     n        integer
C              dimension of full space
C
C     nind     integer
C              dimension of reduced space of free variables
C
C     ind      integer ind(nind)
C              free variables indices on original space
C
C     nliact   integer
C              number of active linear independent linear constraints
C
C     ldh      integer
C              leading dimension of matrix H
C
C     H        double precision H(ldh,n)
C              Hessian to be projected and multiplied by vector d
C
C     ldabar   integer
C              leading dimension of matrix Abar
C      
C     Abar     double precision Abar(ldabar,nliact)
C              matrix that constains QR factorization of linear
C              constraints. Used to calculate Z
C
C     tau      double precision tau(nliact)
C              used in factorization of Abar. Used to calculate Z
C
C     d        double precision d(nred)
C              vector used to calculate Z^T H Z d
C
C     wd1      double precision wd1(nind)
C     wd2      double precision wd2(nind)      
C     zd       double precision zd(nind)
C              working vectors
C      
C     macheps  double precision
C              machine epsilon
C
C     On Return
C      
C     hd       double precision hd(nred)
C              result of multiplication hd = Z^T H Z d
C
C     inform   integer
C              0, if no problem occurs;
C             <0, otherwise
       
      subroutine calchd(n, nind, ind, nliact, ldh, H, ldabar, Abar, tau,
     +     d, wd1, wd2, zd, hd, macheps, inform)

C     SCALAR ARGUMENTS                   
      integer n, nind, nliact, ldh, ldabar, inform
      double precision macheps
      
C     ARRAY ARGUMENTS
      integer ind(nind)
      double precision H(ldh,n), Abar(ldabar,nliact), tau(nliact),
     +     d(nind-nliact), wd1(nind), wd2(nind), zd(nind),
     +     hd(nind-nliact)

C     LOCAL SCALARS
      integer i, j, ii, jj
      double precision tmp1, tmp2
      
C     If nred = nind we just have to calculate H d.
      
      if (nliact .eq. 0) then

C        zd = d.
         
         do i = 1, nind
            zd(i) = d(i)
         end do

C        hd = H zd = H d.

         do i = 1, nind
            hd(i) = 0.0d0
         end do
         
         do j = 1, nind
            jj = ind(j)
            
            tmp1 = zd(j)
            tmp2 = 0.0d0
            
            do i = j+1, nind
               ii = ind(i)
               
               hd(i) = hd(i) + tmp1 * H(ii,jj)
               tmp2 = tmp2 + H(ii,jj) * zd(i)
            end do
            
            hd(j) = hd(j) + tmp1 * H(jj,jj) + tmp2
         end do

         inform = 0
         return
         
      end if
      
C     Calculate zd = Z d.
      
      call multZ(nind, nliact, ldabar, Abar, tau, d, zd, macheps)
      
C     Calculate wd1 = H zd.

      do i = 1, nind
         wd1(i) = 0.0d0
      end do
      
      do j = 1, nind
         jj = ind(j)
         
         tmp1 = zd(j)
         tmp2 = 0.0d0
         
         do i = j+1, nind
            ii = ind(i)
            
            wd1(i) = wd1(i) + tmp1 * H(ii,jj)
            tmp2 = tmp2 + H(ii,jj) * zd(i)
         end do
         
         wd1(j) = wd1(j) + tmp1 * H(jj,jj) + tmp2
      end do
      
C     Calculate hd = Z^T wd1.

      call multZT(nind, nliact, ldabar, Abar, tau, wd1, wd2, hd,
     +     macheps)
      
      inform = 0
      
      end

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

C     This subroutine computes the reduced Hessian times vector d by
C     means of a ``directional finite difference''. The idea is that,
C     at the current point x, the product H d is the limit of 
C 
C     [ Gradient(x + t d) - Gradient(x) ] / t
C
C     As we wish to calculate Z^T H Z d, we have
C 
C     [ Z^T Gradient(x + t Z d) - Z^T Gradient(x) ] / t
C     
C     In this implementation we use
C
C     t = sqrt( macheps ) * max( ||x||_\infty / ||p||_\infty, 1.0d0 )
C
C     provided that p is not equal 0, of course. 
C
C     So, we evaluate the Gradient at the auxiliary point x + t Z d and
C     use the quotient above to approximate Z^T H Z d. To compute the 
C     gradient vector at the auxiliary point it is used evalg or 
C     evalgdiff depending on gtype parameter.
C
C     On Entry
C
C     n        integer
C              dimension of the full space      
C     
C     nind     integer
C              dimension of reduced space of free variables
C
C     ind      integer ind(nind)
C              components ind(1)-th ... ind(nind)-th are the 
C              components that belong to the reduced space
C
C     x        double precision x(n)
C              shrinked point at which the Hessian is being 
C              considered
C
C     xc       double precision xc(n)
C              complement of x to expand it to the full space
C
C     nliact   integer
C              number of linear independent active linear 
C              constraints
C     
C     ldabar   integer
C              leading dimension of matrix Abar
C
C     Abar     double precision Abar(ldabar,nliact)
C              matrix that contains QR factorization of active
C              linear constraints. Used to project a point onto
C              null space of linear constraints
C
C     tau      double precision tau(nliact)
C              used to calculate QR factorization that is stored 
C              in Abar
C     
C     sccol    logical
C              true iff variables should be scaled
C
C     scol     double precision scol(n)
C              variable scaling factors
C      
C     d        double precision d(nind-nliact) 
C              shrinked vector of the Hessian-vector product
C
C     g        double precision g(nind-nliact)
C              shrinked gradient vector at x projected onto null
C              space of linear constraints (Z^T g)
C
C     gtype    integer
C              type of derivatives calculation according to the 
C              following convention:
C
C              0 = true first derivatives;
C
C              1 = means that a finite difference approximation 
C                  will be used
C
C     macheps  double precision
C              smallest positive number such that 1 + macheps is 
C              not equal to 1
C     
C     wd1      double precision wd1(n)
C     wd2      double precision wd2(n)
C     wd3      double precision wd3(n)       
C              n-dimensional double working vectors
C
C     On Return
C
C     zd       double precision zd(nind)
C              matriz-vector product Z d
C     
C     hd       double precision hd(nind-nliact)
C              approximation of Z^T H times p
C
C     inform   integer
C              0 if no problem occured and <0 otherwise.

      subroutine calchddiff(n, nind, ind, x, xc, nliact, ldabar, Abar,
     +     tau, sccol, scol, d, g, gtype, macheps, wd1, wd2, wd3, zd,
     +     hd, inform)
      
C     SCALAR ARGUMENTS
      logical sccol
      integer n, nind, nliact, ldabar, gtype, inform
      double precision macheps

C     ARRAY ARGUMENTS
      integer ind(nind)
      double precision x(n), xc(n), Abar(ldabar,nliact), tau(nliact),
     +     scol(n), d(nind-nliact), g(nind-nliact), wd1(n), wd2(n), 
     +     wd3(n), zd(nind), hd(nind-nliact)

C     LOCAL SCALARS
      integer i, ii, nred
      double precision xsupn, zdsupn, step

      inform = 0

      nred = nind - nliact
      
      if (nliact .eq. 0) then
         do i = 1, nind
            zd(i) = d(i)
         end do
      else
         call multZ(nind, nliact, ldabar, Abar, tau, d, zd, macheps)
      end if

      if (sccol) then
         do i = 1, nind
            ii = ind(i)
            zd(i) = zd(i) * scol(ii)
         end do
      end if
      
C     Compute incremental quotients step
      
      xsupn  = 0.0d0
      zdsupn = 0.0d0
      do i = 1, nind
         xsupn  = max( xsupn, abs( x(i)))
         zdsupn = max(zdsupn, abs(zd(i)))
      end do

C     If d = 0, we have hd = 0
      
      if (zdsupn .le. sqrt(macheps)) then
         do i = 1, nred
            hd(i) = 0.0d0
         end do
         
         return
      end if
      
      step = sqrt(macheps) * max(xsupn/zdsupn, 1.0d0)

C     Set the point at which the gradient of the objective function 
C     will be computed

      do i = 1, nind
         wd1(i) = x(i) + step * zd(i)
      end do

C     Compute the gradient of the objective function at wd
      
      if (gtype .eq. 0) then

         call calcg(n, nind, ind, wd1, xc, sccol, scol, wd2, wd3,
     +        inform)
         
         if (inform .lt. 0) then
            return
         end if

      else if (gtype .eq. 1) then

C        Compute the gradient by finite differences
         
         call calcgdiff(n, nind, ind, wd1, xc, sccol, scol, wd2, wd3,
     +        macheps, inform)
         
         if (inform .lt. 0) then
            return
         end if
      end if

C     Calculate Z^T hd and incremental quotients

      if (nliact .eq. 0) then
         do i = 1, nred
            hd(i) = (wd3(i) - g(i)) / step
         end do    
      else
         call multZT(nind, nliact, ldabar, Abar, tau, wd3, wd1, hd,
     +        macheps)
         
         do i = 1, nred
            hd(i) = (hd(i) - g(i)) / step
         end do 
      end if
      
      end
      
C     ******************************************************************
C     ******************************************************************
 
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.      

      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     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     ******************************************************************
 
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.      

      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     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
      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     ******************************************************************

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.
            
      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     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
      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     *****************************************************************

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
      
      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     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. sqrt(macheps)) 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     *****************************************************************

C     This subroutine computes the squared Euclidian norm of an 
C     n-dimensional vector.
C
C     Parameters of the subroutine:
C
C     On Entry
C
C     n        integer
C              dimension
C
C     x        double precision x(n)
C              vector
C
C     On Return
C
C     The function return the squared Euclidian norm of the 
C     n-dimensional vector x.

      double precision function norm2s(n,x)

C     SCALAR ARGUMENTS
      integer n

C     ARRAY ARGUMENTS
      double precision x(n)

      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     ******************************************************************
C
C     Report of modifications.
C
C     May 24th, 2006.
