dlsei Subroutine

private subroutine dlsei(w, mdw, me, ma, mg, n, prgopt, x, rnorme, rnorml, mode, ws, ip)

This subprogram solves a linearly constrained least squares problem with both equality and inequality constraints, and, if the user requests, obtains a covariance matrix of the solution parameters.

Suppose there are given matrices E, A and G of respective dimensions ME by N, MA by N and MG by N, and vectors F, B and H of respective lengths ME, MA and MG. This subroutine solves the linearly constrained least squares problem

  • EX = F, (E ME by N) (equations to be exactly satisfied)
  • AX = B, (A MA by N) (equations to be approximately satisfied, least squares sense)
  • GX >= H,(G MG by N) (inequality constraints)

The inequalities GX >= H mean that every component of the product GX must be >= the corresponding component of H.

In case the equality constraints cannot be satisfied, a generalized inverse solution residual vector length is obtained for F-EX. This is the minimal length possible for F-EX.

Any values ME >= 0, MA >= 0, or MG >= 0 are permitted. The rank of the matrix E is estimated during the computation. We call this value KRANKE. It is an output parameter in IP(1) defined below. Using a generalized inverse solution of EX=F, a reduced least squares problem with inequality constraints is obtained. The tolerances used in these tests for determining the rank of E and the rank of the reduced least squares problem are given in Sandia Tech. Rept. SAND-78-1290. They can be modified by the user if new values are provided in the option list of the array PRGOPT(*).

The user must dimension all arrays appearing in the call list.. W(MDW,N+1),PRGOPT(),X(N),WS(2(ME+N)+K+(MG+2)(N+7)),IP(MG+2N+2) where K=MAX(MA+MG,N). This allows for a solution of a range of problems in the given working space. The dimension of WS(*) given is a necessary overestimate. Once a particular problem has been run, the output parameter IP(3) gives the actual dimension required for that problem.

The parameters for DLSEI are

  Input.. All TYPE REAL variables are DOUBLE PRECISION

  W(*,*),MDW,   The array W(*,*) is doubly subscripted with
  ME,MA,MG,N    first dimensioning parameter equal to MDW.
                For this discussion let us call M = ME+MA+MG.  Then
                MDW must satisfy MDW >= M.  The condition
                MDW < M is an error.

                The array W(*,*) contains the matrices and vectors

                               (E  F)
                               (A  B)
                               (G  H)

                in rows and columns 1,...,M and 1,...,N+1
                respectively.

                The integers ME, MA, and MG are the
                respective matrix row dimensions
                of E, A and G.  Each matrix has N columns.

  PRGOPT(*)    This real-valued array is the option vector.
               If the user is satisfied with the nominal
               subprogram features set

               PRGOPT(1)=1 (or PRGOPT(1)=1.0)

               Otherwise PRGOPT(*) is a linked list consisting of
               groups of data of the following form

               LINK
               KEY
               DATA SET

               The parameters LINK and KEY are each one word.
               The DATA SET can be comprised of several words.
               The number of items depends on the value of KEY.
               The value of LINK points to the first
               entry of the next group of data within
               PRGOPT(*).  The exception is when there are
               no more options to change.  In that
               case, LINK=1 and the values KEY and DATA SET
               are not referenced.  The general layout of
               PRGOPT(*) is as follows.

            ...PRGOPT(1) = LINK1 (link to first entry of next group)
            .  PRGOPT(2) = KEY1 (key to the option change)
            .  PRGOPT(3) = data value (data value for this change)
            .       .
            .       .
            .       .
            ...PRGOPT(LINK1)   = LINK2 (link to the first entry of
            .                       next group)
            .  PRGOPT(LINK1+1) = KEY2 (key to the option change)
            .  PRGOPT(LINK1+2) = data value
            ...     .
            .       .
            .       .
            ...PRGOPT(LINK) = 1 (no more options to change)

               Values of LINK that are nonpositive are errors.
               A value of LINK > NLINK=100000 is also an error.
               This helps prevent using invalid but positive
               values of LINK that will probably extend
               beyond the program limits of PRGOPT(*).
               Unrecognized values of KEY are ignored.  The
               order of the options is arbitrary and any number
               of options can be changed with the following
               restriction.  To prevent cycling in the
               processing of the option array, a count of the
               number of options changed is maintained.
               Whenever this count exceeds NOPT=1000, an error
               message is printed and the subprogram returns.

               Options..

               KEY=1
                      Compute in W(*,*) the N by N
               covariance matrix of the solution variables
               as an output parameter.  Nominally the
               covariance matrix will not be computed.
               (This requires no user input.)
               The data set for this option is a single value.
               It must be nonzero when the covariance matrix
               is desired.  If it is zero, the covariance
               matrix is not computed.  When the covariance matrix
               is computed, the first dimensioning parameter
               of the array W(*,*) must satisfy MDW >= MAX(M,N).

               KEY=10
                      Suppress scaling of the inverse of the
               normal matrix by the scale factor RNORM**2/
               MAX(1, no. of degrees of freedom).  This option
               only applies when the option for computing the
               covariance matrix (KEY=1) is used.  With KEY=1 and
               KEY=10 used as options the unscaled inverse of the
               normal matrix is returned in W(*,*).
               The data set for this option is a single value.
               When it is nonzero no scaling is done.  When it is
               zero scaling is done.  The nominal case is to do
               scaling so if option (KEY=1) is used alone, the
               matrix will be scaled on output.

               KEY=2
                      Scale the nonzero columns of the
                      entire data matrix.
               (E)
               (A)
               (G)

               to have length one.  The data set for this
               option is a single value.  It must be
               nonzero if unit length column scaling
               is desired.

               KEY=3
                      Scale columns of the entire data matrix
               (E)
               (A)
               (G)

               with a user-provided diagonal matrix.
               The data set for this option consists
               of the N diagonal scaling factors, one for
               each matrix column.

               KEY=4
                      Change the rank determination tolerance for
               the equality constraint equations from
               the nominal value of SQRT(DRELPR).  This quantity can
               be no smaller than DRELPR, the arithmetic-
               storage precision.  The quantity DRELPR is the
               largest positive number such that T=1.+DRELPR
               satisfies T == 1.  The quantity used
               here is internally restricted to be at
               least DRELPR.  The data set for this option
               is the new tolerance.

               KEY=5
                      Change the rank determination tolerance for
               the reduced least squares equations from
               the nominal value of SQRT(DRELPR).  This quantity can
               be no smaller than DRELPR, the arithmetic-
               storage precision.  The quantity used
               here is internally restricted to be at
               least DRELPR.  The data set for this option
               is the new tolerance.

               For example, suppose we want to change
               the tolerance for the reduced least squares
               problem, compute the covariance matrix of
               the solution parameters, and provide
               column scaling for the data matrix.  For
               these options the dimension of PRGOPT(*)
               must be at least N+9.  The Fortran statements
               defining these options would be as follows:

               PRGOPT(1)=4 (link to entry 4 in PRGOPT(*))
               PRGOPT(2)=1 (covariance matrix key)
               PRGOPT(3)=1 (covariance matrix wanted)

               PRGOPT(4)=7 (link to entry 7 in PRGOPT(*))
               PRGOPT(5)=5 (least squares equas.  tolerance key)
               PRGOPT(6)=... (new value of the tolerance)

               PRGOPT(7)=N+9 (link to entry N+9 in PRGOPT(*))
               PRGOPT(8)=3 (user-provided column scaling key)

               CALL DCOPY (N, D, 1, PRGOPT(9), 1)  (Copy the N
                 scaling factors from the user array D(*)
                 to PRGOPT(9)-PRGOPT(N+8))

               PRGOPT(N+9)=1 (no more options to change)

               The contents of PRGOPT(*) are not modified
               by the subprogram.
               The options for WNNLS( ) can also be included
               in this array.  The values of KEY recognized
               by WNNLS( ) are 6, 7 and 8.  Their functions
               are documented in the usage instructions for
               subroutine WNNLS( ).  Normally these options
               do not need to be modified when using [[DLSEI]].

  IP(1),       The amounts of working storage actually
  IP(2)        allocated for the working arrays WS(*) and
               IP(*), respectively.  These quantities are
               compared with the actual amounts of storage
               needed by [[DLSEI]].  Insufficient storage
               allocated for either WS(*) or IP(*) is an
               error.  This feature was included in [[DLSEI]]
               because miscalculating the storage formulas
               for WS(*) and IP(*) might very well lead to
               subtle and hard-to-find execution errors.

               The length of WS(*) must be at least

               LW = 2*(ME+N)+K+(MG+2)*(N+7)

               where K = max(MA+MG,N)
               This test will not be made if IP(1)<=0.

               The length of IP(*) must be at least

               LIP = MG+2*N+2
               This test will not be made if IP(2)<=0.

  Output.. All TYPE REAL variables are DOUBLE PRECISION

  X(*),RNORME,  The array X(*) contains the solution parameters
  RNORML        if the integer output flag MODE = 0 or 1.
                The definition of MODE is given directly below.
                When MODE = 0 or 1, RNORME and RNORML
                respectively contain the residual vector
                Euclidean lengths of F - EX and B - AX.  When
                MODE=1 the equality constraint equations EX=F
                are contradictory, so RNORME /= 0.  The residual
                vector F-EX has minimal Euclidean length.  For
                MODE >= 2, none of these parameters is defined.

  MODE          Integer flag that indicates the subprogram
                status after completion.  If MODE >= 2, no
                solution has been computed.

                MODE =

                0  Both equality and inequality constraints
                   are compatible and have been satisfied.

                1  Equality constraints are contradictory.
                   A generalized inverse solution of EX=F was used
                   to minimize the residual vector length F-EX.
                   In this sense, the solution is still meaningful.

                2  Inequality constraints are contradictory.

                3  Both equality and inequality constraints
                   are contradictory.

                The following interpretation of
                MODE=1,2 or 3 must be made.  The
                sets consisting of all solutions
                of the equality constraints EX=F
                and all vectors satisfying GX >= H
                have no points in common.  (In
                particular this does not say that
                each individual set has no points
                at all, although this could be the
                case.)

                4  Usage error occurred.  The value
                   of MDW is < ME+MA+MG, MDW is
                   < N and a covariance matrix is
                   requested, or the option vector
                   PRGOPT(*) is not properly defined,
                   or the lengths of the working arrays
                   WS(*) and IP(*), when specified in
                   IP(1) and IP(2) respectively, are not
                   long enough.

  W(*,*)        The array W(*,*) contains the N by N symmetric
                covariance matrix of the solution parameters,
                provided this was requested on input with
                the option vector PRGOPT(*) and the output
                flag is returned with MODE = 0 or 1.

  IP(*)         The integer working array has three entries
                that provide rank and working array length
                information after completion.

                   IP(1) = rank of equality constraint
                           matrix.  Define this quantity
                           as KRANKE.

                   IP(2) = rank of reduced least squares
                           problem.

                   IP(3) = the amount of storage in the
                           working array WS(*) that was
                           actually used by the subprogram.
                           The formula given above for the length
                           of WS(*) is a necessary overestimate.
                           If exactly the same problem matrices
                           are used in subsequent executions,
                           the declared dimension of WS(*) can
                           be reduced to this output value.
  User Designated
  Working Arrays..

  WS(*),IP(*)              These are respectively type real
                           and type integer working arrays.
                           Their required minimal lengths are
                           given above.

References

  • K. H. Haskell and R. J. Hanson, An algorithm for linear least squares problems with equality and nonnegativity constraints, Report SAND77-0552, Sandia Laboratories, June 1978.
  • K. H. Haskell and R. J. Hanson, Selected algorithms for the linearly constrained least squares problem - a users guide, Report SAND78-1290, Sandia Laboratories, August 1979.
  • K. H. Haskell and R. J. Hanson, An algorithm for linear least squares problems with equality and nonnegativity constraints, Mathematical Programming 21 (1981), pp. 98-118.
  • R. J. Hanson and K. H. Haskell, Two algorithms for the linearly constrained least squares problem, ACM Transactions on Mathematical Software, September 1982.

Revision history

  • 790701 DATE WRITTEN. Hanson, R. J., (SNLA), Haskell, K. H., (SNLA)
  • 890531 Changed all specific intrinsics to generic. (WRB)
  • 890618 Completely restructured and extensively revised (WRB & RWC)
  • 890831 REVISION DATE from Version 3.2
  • 891214 Prologue converted to Version 4.0 format. (BAB)
  • 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ)
  • 900510 Convert XERRWV calls to XERMSG calls. (RWC)
  • 900604 DP version created from SP version. (RWC)
  • 920501 Reformatted the REFERENCES section. (WRB)

Arguments

Type IntentOptional Attributes Name
real(kind=wp) :: w(mdw,*)
integer, intent(in) :: mdw
integer :: me
integer :: ma
integer :: mg
integer :: n
real(kind=wp) :: prgopt(*)
real(kind=wp) :: x(*)
real(kind=wp) :: rnorme
real(kind=wp) :: rnorml
integer :: mode
real(kind=wp) :: ws(*)
integer :: ip(3)

Calls

proc~~dlsei~~CallsGraph proc~dlsei bspline_defc_module::dlsei proc~dasum bspline_blas_module::dasum proc~dlsei->proc~dasum proc~daxpy bspline_blas_module::daxpy proc~dlsei->proc~daxpy proc~dcopy bspline_blas_module::dcopy proc~dlsei->proc~dcopy proc~ddot bspline_blas_module::ddot proc~dlsei->proc~ddot proc~dh12 bspline_defc_module::dh12 proc~dlsei->proc~dh12 proc~dlsi bspline_defc_module::dlsi proc~dlsei->proc~dlsi proc~dnrm2 bspline_blas_module::dnrm2 proc~dlsei->proc~dnrm2 proc~dscal bspline_blas_module::dscal proc~dlsei->proc~dscal proc~dswap bspline_blas_module::dswap proc~dlsei->proc~dswap proc~dh12->proc~daxpy proc~dh12->proc~ddot proc~dh12->proc~dswap proc~dlsi->proc~dasum proc~dlsi->proc~daxpy proc~dlsi->proc~dcopy proc~dlsi->proc~ddot proc~dlsi->proc~dh12 proc~dlsi->proc~dscal proc~dlsi->proc~dswap proc~dhfti bspline_defc_module::dhfti proc~dlsi->proc~dhfti proc~dlpdp bspline_defc_module::dlpdp proc~dlsi->proc~dlpdp proc~dhfti->proc~dh12 proc~dlpdp->proc~dcopy proc~dlpdp->proc~ddot proc~dlpdp->proc~dnrm2 proc~dlpdp->proc~dscal proc~dwnnls bspline_defc_module::dwnnls proc~dlpdp->proc~dwnnls proc~dwnlsm bspline_defc_module::dwnlsm proc~dwnnls->proc~dwnlsm proc~dwnlsm->proc~dasum proc~dwnlsm->proc~daxpy proc~dwnlsm->proc~dcopy proc~dwnlsm->proc~dh12 proc~dwnlsm->proc~dnrm2 proc~dwnlsm->proc~dscal proc~dwnlsm->proc~dswap proc~drotm bspline_blas_module::drotm proc~dwnlsm->proc~drotm proc~drotmg bspline_blas_module::drotmg proc~dwnlsm->proc~drotmg proc~dwnlit bspline_defc_module::dwnlit proc~dwnlsm->proc~dwnlit proc~idamax bspline_blas_module::idamax proc~dwnlsm->proc~idamax proc~dwnlit->proc~dcopy proc~dwnlit->proc~dh12 proc~dwnlit->proc~dscal proc~dwnlit->proc~dswap proc~dwnlit->proc~drotm proc~dwnlit->proc~drotmg proc~dwnlit->proc~idamax proc~dwnlt1 bspline_defc_module::dwnlt1 proc~dwnlit->proc~dwnlt1 proc~dwnlt2 bspline_defc_module::dwnlt2 proc~dwnlit->proc~dwnlt2 proc~dwnlt3 bspline_defc_module::dwnlt3 proc~dwnlit->proc~dwnlt3 proc~dwnlt1->proc~idamax proc~dwnlt3->proc~dswap

Called by

proc~~dlsei~~CalledByGraph proc~dlsei bspline_defc_module::dlsei proc~dfcmn bspline_defc_module::dfcmn proc~dfcmn->proc~dlsei proc~dfc bspline_defc_module::dfc proc~dfc->proc~dfcmn

Source Code

   subroutine dlsei (w, mdw, me, ma, mg, n, prgopt, x, rnorme, &
                     rnorml, mode, ws, ip)

   integer,intent(in) :: mdw
   real(wp) :: w(mdw,*)
   integer :: me
   integer :: ma
   integer :: mg
   integer :: n
   real(wp) :: prgopt(*)
   real(wp) :: x(*)
   real(wp) :: rnorme
   real(wp) :: rnorml
   integer :: mode
   real(wp) :: ws(*)
   integer :: ip(3)

   real(wp) :: enorm, fnorm, gam, rb, rn, rnmax, size, &
               sn, snmax, t, tau, uj, up, vj, xnorm, xnrme
   integer :: i, imax, j, jp1, k, key, kranke, last, lchk, link, m, &
              mapke1, mdeqc, mend, mep1, n1, n2, next, nlink, nopt, np1, &
              ntimes
   logical :: cov, done
   character(len=8) :: xern1, xern2, xern3, xern4

   ! Set the nominal tolerance used in the code for the equality
   ! constraint equations.
   tau = sqrt(drelpr)

   ! Check that enough storage was allocated in WS(*) and IP(*).
   mode = 4
   if (min(n,me,ma,mg) < 0) then
      write (xern1, '(I8)') n
      write (xern2, '(I8)') me
      write (xern3, '(I8)') ma
      write (xern4, '(I8)') mg
      write(*,*) 'ALL OF THE VARIABLES N, ME,' // &
                 ' MA, MG MUST BE >= 0. ENTERED ROUTINE WITH: ' // &
                    'N = ' // trim(adjustl(xern1)) // &
                 ', ME = ' // trim(adjustl(xern2)) // &
                 ', MA = ' // trim(adjustl(xern3)) // &
                 ', MG = ' // trim(adjustl(xern4))
      return
   endif

   if (ip(1)>0) then
      lchk = 2*(me+n) + max(ma+mg,n) + (mg+2)*(n+7)
      if (ip(1)<lchk) then
         write (xern1, '(I8)') lchk
         write(*,*) 'INSUFFICIENT STORAGE ' // &
                    'ALLOCATED FOR WS(*), NEED LW = ' // xern1
         return
      endif
   endif

   if (ip(2)>0) then
      lchk = mg + 2*n + 2
      if (ip(2)<lchk) then
         write (xern1, '(I8)') lchk
         write(*,*) 'INSUFFICIENT STORAGE ' // &
                    'ALLOCATED FOR IP(*), NEED LIP = ' // xern1
         return
      endif
   endif

   ! Compute number of possible right multiplying Householder
   ! transformations.

   m = me + ma + mg
   if (n<=0 .or. m<=0) then
      mode = 0
      rnorme = 0
      rnorml = 0
      return
   endif

   if (mdw<m) then
      write(*,*) 'MDW < ME+MA+MG IS AN ERROR'
      return
   endif

   np1 = n + 1
   kranke = min(me,n)
   n1 = 2*kranke + 1
   n2 = n1 + n

   ! Set nominal values.
   !
   ! The nominal column scaling used in the code is
   ! the identity scaling.

   call dcopy (n, [1.0_wp], 0, ws(n1), 1)

   ! No covariance matrix is nominally computed.

   cov = .false.

   ! Process option vector.
   ! Define bound for number of options to change.

   nopt = 1000
   ntimes = 0

   ! Define bound for positive values of LINK.

   nlink = 100000
   last = 1
   link = prgopt(1)
   if (link==0 .or. link>nlink) then
      write(*,*) 'THE OPTION VECTOR IS UNDEFINED'
      return
   endif

   do
      if (link<=1) exit
      ntimes = ntimes + 1
      if (ntimes>nopt) then
         write(*,*) 'THE LINKS IN THE OPTION VECTOR ARE CYCLING.'
         return
      endif

      key = prgopt(last+1)
      if (key==1) then
         cov = prgopt(last+2) /= 0.0_wp
      elseif (key==2 .and. prgopt(last+2)/=0.0_wp) then
         do j = 1,n
            t = dnrm2(m,w(1,j),1)
            if (t/=0.0_wp) t = 1.0_wp/t
            ws(j+n1-1) = t
         end do
      elseif (key==3) then
         call dcopy (n, prgopt(last+2), 1, ws(n1), 1)
      elseif (key==4) then
         tau = max(drelpr,prgopt(last+2))
      endif

      next = prgopt(link)
      if (next<=0 .or. next>nlink) then
         write(*,*) 'THE OPTION VECTOR IS UNDEFINED'
         return
      endif

      last = link
      link = next
   end do

   do j = 1,n
      call dscal (m, ws(n1+j-1), w(1,j), 1)
   end do

   if (cov .and. mdw<n) then
      write(*,*) 'MDW < N WHEN COV MATRIX NEEDED, IS AN ERROR'
      return
   endif

   ! Problem definition and option vector OK.

   mode = 0

   ! Compute norm of equality constraint matrix and right side.

   enorm = 0.0_wp
   do j = 1,n
      enorm = max(enorm,dasum(me,w(1,j),1))
   end do

   fnorm = dasum(me,w(1,np1),1)
   snmax = 0.0_wp
   rnmax = 0.0_wp
   do i = 1,kranke

      ! Compute maximum ratio of vector lengths. Partition is at
      ! column I.

      do k = i,me
         sn = ddot(n-i+1,w(k,i),mdw,w(k,i),mdw)
         rn = ddot(i-1,w(k,1),mdw,w(k,1),mdw)
         if (rn==0.0_wp .and. sn>snmax) then
            snmax = sn
            imax = k
         elseif (k==i .or. sn*rnmax>rn*snmax) then
            snmax = sn
            rnmax = rn
            imax = k
         endif
      end do

      ! Interchange rows if necessary.

      if (i/=imax) call dswap (np1, w(i,1), mdw, w(imax,1), mdw)
      if (snmax>rnmax*tau**2) then
         ! Eliminate elements I+1,...,N in row I.
         call dh12 (1, i, i+1, n, w(i,1), mdw, ws(i), w(i+1,1), mdw, 1, m-i)
      else
         kranke = i - 1
         exit
      endif
   end do

   ! Save diagonal terms of lower trapezoidal matrix.

   call dcopy (kranke, w, mdw+1, ws(kranke+1), 1)

   ! Use Householder transformation from left to achieve
   ! KRANKE by KRANKE upper triangular form.

   if (kranke<me) then
      do k = kranke,1,-1
         ! Apply transformation to matrix cols. 1,...,K-1.
         call dh12 (1, k, kranke+1, me, w(1,k), 1, up, w, 1, mdw, k-1)
         ! Apply to rt side vector.
         call dh12 (2, k, kranke+1, me, w(1,k), 1, up, w(1,np1), 1, 1, 1)
      end do
   endif

   ! Solve for variables 1,...,KRANKE in new coordinates.

   call dcopy (kranke, w(1, np1), 1, x, 1)
   do i = 1,kranke
      x(i) = (x(i)-ddot(i-1,w(i,1),mdw,x,1))/w(i,i)
   end do

   ! Compute residuals for reduced problem.

   mep1 = me + 1
   rnorml = 0.0_wp
   do i = mep1,m
      w(i,np1) = w(i,np1) - ddot(kranke,w(i,1),mdw,x,1)
      sn = ddot(kranke,w(i,1),mdw,w(i,1),mdw)
      rn = ddot(n-kranke,w(i,kranke+1),mdw,w(i,kranke+1),mdw)
      if (rn<=sn*tau**2 .and. kranke<n) &
         call dcopy (n-kranke, [0.0_wp], 0, w(i,kranke+1), mdw)
   end do

   ! Compute equality constraint equations residual length.

   rnorme = dnrm2(me-kranke,w(kranke+1,np1),1)

   ! Move reduced problem data upward if KRANKE<ME.

   if (kranke<me) then
      do j = 1,np1
         call dcopy (m-me, w(me+1,j), 1, w(kranke+1,j), 1)
      end do
   endif

   ! Compute solution of reduced problem.

   call dlsi(w(kranke+1, kranke+1), mdw, ma, mg, n-kranke, prgopt, &
             x(kranke+1), rnorml, mode, ws(n2), ip(2))

   ! Test for consistency of equality constraints.
   done = .false.

   if (me>0) then
      mdeqc = 0
      xnrme = dasum(kranke,w(1,np1),1)
      if (rnorme>tau*(enorm*xnrme+fnorm)) mdeqc = 1
      mode = mode + mdeqc

      ! Check if solution to equality constraints satisfies inequality
      ! constraints when there are no degrees of freedom left.

      if (kranke==n .and. mg>0) then
         xnorm = dasum(n,x,1)
         mapke1 = ma + kranke + 1
         mend = ma + kranke + mg
         do i = mapke1,mend
            size = dasum(n,w(i,1),mdw)*xnorm + abs(w(i,np1))
            if (w(i,np1)>tau*size) then
               mode = mode + 2
               done = .true.
               exit
            endif
         end do
      endif
   endif

   if (.not. done) then
      ! Replace diagonal terms of lower trapezoidal matrix.

      if (kranke>0) then
         call dcopy (kranke, ws(kranke+1), 1, w, mdw+1)
         ! Reapply transformation to put solution in original coordinates.
         do i = kranke,1,-1
            call dh12 (2, i, i+1, n, w(i,1), mdw, ws(i), x, 1, 1, 1)
         end do

         ! Compute covariance matrix of equality constrained problem.

         if (cov) then
            do j = min(kranke,n-1),1,-1
               rb = ws(j)*w(j,j)
               if (rb/=0.0_wp) rb = 1.0_wp/rb
               jp1 = j + 1
               do i = jp1,n
                  w(i,j) = rb*ddot(n-j,w(i,jp1),mdw,w(j,jp1),mdw)
               end do
               gam = 0.5_wp*rb*ddot(n-j,w(jp1,j),1,w(j,jp1),mdw)
               call daxpy (n-j, gam, w(j,jp1), mdw, w(jp1,j), 1)
               do i = jp1,n
                  do k = i,n
                     w(i,k) = w(i,k) + w(j,i)*w(k,j) + w(i,j)*w(j,k)
                     w(k,i) = w(i,k)
                  end do
               end do
               uj = ws(j)
               vj = gam*uj
               w(j,j) = uj*vj + uj*vj
               do i = jp1,n
                  w(j,i) = uj*w(i,j) + vj*w(j,i)
               end do
               call dcopy (n-j, w(j, jp1), mdw, w(jp1,j), 1)
            end do
         endif
      endif

      ! Apply the scaling to the covariance matrix.

      if (cov) then
         do i = 1,n
            call dscal (n, ws(i+n1-1), w(i,1), mdw)
            call dscal (n, ws(i+n1-1), w(1,i), 1)
         end do
      endif

   end if

   ! Rescale solution vector.

   if (mode<=1) then
      do j = 1,n
         x(j) = x(j)*ws(n1+j-1)
      end do
   endif

   ip(1) = kranke
   ip(3) = ip(3) + 2*kranke + n

   end subroutine dlsei