NLSL: qrsolv.f90 Source File

NLSL

- Main Page
- Modules
- Data Types List
- Files

- File List
- File Members

qrsolv.f90
Go to the documentation of this file.
1 subroutine qrsolv(n,r,ldr,ipvt,diag,qtb,x,sdiag,wa)
2 integer n,ldr
3 integer ipvt(n)
4 double precision r(ldr,n),diag(n),qtb(n),x(n),sdiag(n),wa(n)
5 c **********
6 c
7 c subroutine qrsolv
8 c
9 c Given an m by n matrix A, an n by n diagonal matrix D,
10 c and an m-vector B, the problem is to determine an X which
11 c solves the system
12 c
13 c A*X = B , D*X = 0 ,
14 c
15 c in the least squares sense.
16 c
17 c This subroutine completes the solution of the problem
18 c if it is provided with the necessary information from the
19 c QR factorization, with column pivoting, of A. That is, if
20 c A*P = Q*R, where P is a permutationf matrix, Q has orthogonal
21 c columns, and R is an upper triangular matrix with diagonal
22 c elements of nonincreasing magnitude, then qrsolv expects
23 c the full upper triangle of R, the permutation matrix P,
24 c and the first n components of (Q transpose)*B. The system
25 c A*X = B, D*X = 0, is then equivalent to
26 c
27 c t t
28 c R*Z = Q *B , P *D*P*Z = 0 ,
29 c
30 c where X = P*Z. If this system does not have full rank,
31 c then a least squares solution is obtained. On output qrsolv
32 c also provides an upper triangular matrix S such that
33 c
34 c t t t
35 C P *(A *A + D*D)*P = S *S .
36 c
37 c S is computed within qrsolv and may be of separate interest.
38 c
39 c The subroutine statement is
40 c
41 c subroutine qrsolv(n,r,ldr,ipvt,diag,qtb,x,sdiag,wa)
42 c
43 c where
44 c
45 c n is a positive integer input variable set to the order of r.
46 c
47 c r is an n by n array. On input the full upper triangle
48 c must contain the full upper triangle of the matrix r.
49 c On output the full upper triangle is unaltered, and the
50 c strict lower triangle contains the strict upper triangle
51 c (transposed) of the upper triangular matrix S
52 c
53 c ldr is a positive integer input variable not less than n
54 c which specifies the leading dimension of the array r.
55 c
56 c ipvt is an integer input array of length n which defines the
57 c permutation matrix p such that A*P = Q*R. Column j of P
58 c is column ipvt(j) of the identity matrix.
59 c
60 c diag is an input array of length n which must contain the
61 c diagonal elements of the matrix D.
62 c
63 c qtb is an input array of length n which must contain the first
64 c n elements of the vector (Q transpose)*B.
65 c
66 c x is an output array of length n which contains the least
67 c squares solution of the system A*X = B, D*X = 0.
68 c
69 c sdiag is an output array of length n which contains the
70 c diagonal elements of the upper triangular matrix S.
71 c
72 c wa is a work array of length n.
73 c
74 c Subprograms called
75 c
76 c Fortran-supplied ... dabs,dsqrt
77 c
78 c Argonne National Laboratory. MINPACK project. March 1980.
79 c Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More
80 c
81 c **********
82 integer i,j,jp1,k,kp1,l,nsing
83 double precision cos,cotan,p5,p25,qtbpj,sin,sum,tan,temp,zero
84 data p5,p25,zero /5.0d-1,2.5d-1,0.0d0/
85 c
86 c----------------------------------------------------------------------
87 c Copy R and (Q transpose)*B to preserve input and initialize S.
88 c In particular, save the diagonal elements of R in X.
89 c----------------------------------------------------------------------
90 do 20 j = 1, n
91 do 10 i = j, n
92 r(i,j) = r(j,i)
93 10 continue
94 x(j) = r(j,j)
95 wa(j) = qtb(j)
96 20 continue
97 c
98 c----------------------------------------------------------------------
99 c Eliminate the diagonal matrix D using a Givens rotation.
100 c----------------------------------------------------------------------
101 do 100 j = 1, n
102 c
103 c Prepare the row of D to be eliminated, locating the
104 c diagonal element using P from the QR factorization.
105 c
106 l = ipvt(j)
107 if (diag(l) .ne. zero) then
108 do 30 k = j, n
109 sdiag(k) = zero
110 30 continue
111 sdiag(j) = diag(l)
112 c
113 c The transformations to eliminate the row of D
114 c modify only a single element of (Q transpose)*B
115 c beyond the first n, which is initially zero.
116 c
117 qtbpj = zero
118 do 80 k = j, n
119 c
120 c Determine a Givens rotation which eliminates the
121 c appropriate element in the current row of D
122 c
123 if (sdiag(k) .ne. zero) then
124 if (dabs(r(k,k)) .ge. dabs(sdiag(k))) then
125 tan = sdiag(k)/r(k,k)
126 cos = p5/dsqrt(p25+p25*tan**2)
127 sin = cos*tan
128 else
129 cotan = r(k,k)/sdiag(k)
130 sin = p5/dsqrt(p25+p25*cotan**2)
131 cos = sin*cotan
132 end if
133 c
134 c Compute the modified diagonal element of R and
135 c the modified element of ((Q transpose)*B,0).
136 c
137 r(k,k) = cos*r(k,k) + sin*sdiag(k)
138 temp = cos*wa(k) + sin*qtbpj
139 qtbpj = -sin*wa(k) + cos*qtbpj
140 wa(k) = temp
141 c
142 c Accumulate the tranformation in the row of S.
143 c
144 kp1 = k + 1
145 if (kp1 .le. n) then
146 do 60 i = kp1, n
147 temp = cos*r(i,k) + sin*sdiag(i)
148 sdiag(i) = -sin*r(i,k) + cos*sdiag(i)
149 r(i,k) = temp
150 60 continue
151 end if
152 end if
153 80 continue
154 end if
155 c
156 c Store the diagonal element of S and restore
157 c the corresponding diagonal element of r.
158 c
159 sdiag(j) = r(j,j)
160 r(j,j) = x(j)
161 100 continue
162 c
163 c Solve the triangular system for z. If the system is
164 c singular, then obtain a least squares solution.
165 c
166 nsing = n
167 do 110 j = 1, n
168 if (sdiag(j) .eq. zero .and. nsing .eq. n) nsing = j - 1
169 if (nsing .lt. n) wa(j) = zero
170 110 continue
171 c
172 if (nsing .ge. 1) then
173 do 140 k = 1, nsing
174 j = nsing - k + 1
175 sum = zero
176 jp1 = j + 1
177 if (jp1 .le. nsing) then
178 do 120 i = jp1, nsing
179 sum = sum + r(i,j)*wa(i)
180 120 continue
181 end if
182 wa(j) = (wa(j) - sum)/sdiag(j)
183 140 continue
184 end if
185 c
186 c Permute the components of Z back to components of X.
187 c
188 do 160 j = 1, n
189 l = ipvt(j)
190 x(l) = wa(j)
191 160 continue
192 c
193 return
194 end
qrsolv
subroutine qrsolv(n, r, ldr, ipvt, diag, qtb, x, sdiag, wa)
Definition: qrsolv.f90:2