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.
Type | Intent | Optional | 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) |
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