NLSL: qrutil.f90 Source File

NLSL

- Main Page
- Modules
- Data Types List
- Files

- File List
- File Members

qrutil.f90
Go to the documentation of this file.
1 c NLSL Version 1.3.2
2 c This file contains subroutines QTBVEC and RSOLVE
3 c----------------------------------------------------------------------
4 c =========================
5 c subroutine QTBVEC
6 c =========================
7 c
8 c This subroutine is one of the steps necessary to complete the
9 c solution of a set of linear equations A*x=b using the QR decomposition
10 c of the matrix A provided by subroutine QRFAC form the MINPACK library:
11 c A*P = Q*R
12 c where R is upper triangular, Q is an orthogonal matrix, and P
13 c is a permutation matrix that accounts for any column pivoting that
14 c occurred during the solution of A. Given the vector b, this routine
15 c calculates the vector Q(transpose)*b that may be subsequently be
16 c used to solve the original equation for x by solving the triangular
17 c matrix equation
18 c
19 c Input parameters:
20 c
21 c M: Number of rows in Q
22 c
23 c N: Number of columns in Q (and dimension of R,RDIAG,and QTB)
24 c
25 c Q: The strict upper triangle of Q is assumed to contain
26 c the strict upper triangle of R and the lower triangle of Q
27 c contains a factored form of Q, (as returned by QRFAC).
28 c
29 c LDQ: Leading dimension of the Q array
30 c
31 c RDIAG: Diagonal elements of R (also returned by QRFAC)
32 c
33 c B: Contains M-vector b.
34 c
35 c QTB: On output, the first N elements contain the N-vector
36 c Q(transpose)*b product.
37 c----------------------------------------------------------------------
38 subroutine qtbvec(m,n,q,ldq,qraux,b,qtb)
39 implicit none
40 integer ldq,n,m
41 double precision q(ldq,n),qraux(n),b(m),qtb(m)
42 c
43 integer i,j
44 double precision qtemp,sum,temp,ZERO
45 parameter(zero=0.0d0)
46 c
47 do i=1,m
48 qtb(i)=b(i)
49 end do
50 c
51 do j=1,n
52 if (qraux(j).ne.zero) then
53 qtemp=q(j,j)
54 q(j,j)=qraux(j)
55 sum=zero
56 do i=j,m
57 sum=sum+q(i,j)*qtb(i)
58 end do
59 temp=-sum/q(j,j)
60 do i=j,m
61 qtb(i)=qtb(i)+q(i,j)*temp
62 end do
63 end if
64 c
65 q(j,j)=qtemp
66 end do
67 c
68 return
69 end
70
71
72 c----------------------------------------------------------------------
73 c =========================
74 c subroutine RSOLVE
75 c =========================
76 c
77 c This subroutine is one of the steps necessary to complete the
78 c solution of a set of linear equations A*x=b using the QR decomposition
79 c of the matrix A provided by subroutine QRFAC form the MINPACK library:
80 c
81 c A*P = Q*R
82 c
83 c where R is upper triangular, Q is an orthogonal matrix, and P
84 c is a permutation matrix that accounts for any column pivoting that
85 c occurred during the solution of A. Given the vectors x and Qtb
86 c [Q(transpose)*b], this routine solves the diagonal equation R*x=Qt*b
87 c used to solve the original equation for x by solving the triangular
88 c matrix equation
89 c
90 c Input parameters:
91 c
92 c M: Number of rows in Q
93 c
94 c N: Number of columns in Q (and dimension of R,RDIAG,and QTB)
95 c
96 c Q: The strict upper triangle of Q is assumed to contain
97 c the strict upper triangle of R and the lower triangle of Q
98 c contains a factored form of Q, (as returned by QRFAC).
99 c
100 c LDQ: Leading dimension of the Q array
101 c
102 c RDIAG: Diagonal elements of R (also returned by QRFAC)
103 c
104 c QTB: On input, the first N elements contain the N-vector
105 c Q(transpose)*b product.
106 c
107 c X: On output, an N-vector containing solution of A*x=b
108 c
109 c RSD: On input, the M-vector b for which the solution/residuals
110 c are desired
111 c
112 c On output, an M-vector containing the residuals of the
113 c least-squares problem, b-A*x.
114 c
115 c----------------------------------------------------------------------
116 subroutine rsolve( m,n,q,ldq,qraux,qtb,x,rcalc,rsd )
117 implicit none
118 integer m,n,ldq
119 double precision q(ldq,n),qraux(n),qtb(n),x(m),rsd(m)
120 logical rcalc
121 c
122 integer i,j,ju,jj
123 double precision qtemp,sum,temp
124 c
125 double precision ZERO
126 parameter(zero=0.0d0)
127 c
128 c######################################################################
129 c
130 do i=1,n
131 x(i)=qtb(i)
132 end do
133 c
134 c --- Solve R*x = Q(transpose)*b
135 c
136 do jj=1,n
137 j=n-jj+1
138 if (q(j,j).eq.zero) go to 4
139 x(j)=x(j)/q(j,j)
140 if (j.gt.1) then
141 temp=-x(j)
142 do i=1,j-1
143 x(i)=temp*q(i,j)+x(i)
144 end do
145 end if
146 end do
147 c
148 c --- If required, calculate residual vector b-A*x
149 c
150 4 if (rcalc) then
151 do i=1,m
152 if (i.le.n) then
153 rsd(i)=zero
154 else
155 rsd(i)=qtb(i)
156 end if
157 end do
158 c
159 ju=min0(n,m-1)
160 do jj=1,ju
161 j=ju-jj+1
162 if (qraux(j).ne.zero) then
163 qtemp=q(j,j)
164 q(j,j)=qraux(j)
165 c
166 sum=zero
167 do i=j,m
168 sum=sum+q(i,j)*rsd(j)
169 end do
170 temp=-sum/q(j,j)
171 c
172 do i=j,m
173 rsd(i)=temp*q(i,j)+rsd(i)
174 end do
175 q(j,j)=qtemp
176 end if
177 end do
178 end if
179 c
180 return
181 end
qtbvec
subroutine qtbvec(m, n, q, ldq, qraux, b, qtb)
Definition: qrutil.f90:39
rsolve
subroutine rsolve(m, n, q, ldq, qraux, qtb, x, rcalc, rsd)
Definition: qrutil.f90:117