NLSL: covar.f90 Source File

NLSL

- Main Page
- Modules
- Data Types List
- Files

- File List
- File Members

covar.f90
Go to the documentation of this file.
1 subroutine covar(n,r,ldr,ipvt,tol,wa)
2 integer n,ldr
3 integer ipvt(n)
4 double precision tol
5 double precision r(ldr,n),wa(n)
6 c **********
7 c
8 c subroutine covar
9 c
10 c given an m by n matrix a, the problem is to determine
11 c the covariance matrix corresponding to a, defined as
12 c
13 c t
14 c inverse(a *a)
15 c
16 c this subroutine completes the solution of the problem
17 c if it is provided with the necessary information from the
18 c qr factorization, with column pivoting, of a. that is, if
19 c a*p = q*r, where p is a permutation matrix, q has orthogonal
20 c columns, and r is an upper triangular matrix with diagonal
21 c elements of nonincreasing magnitude, then covar expects the
22 c full upper triangle of r and the permutation matrix p.
23 c the covariance matrix is then computed as
24 c
25 c t t
26 c p*inverse(r *r)*p
27 c
28 c if a is nearly rank deficient, it may be desirable to compute
29 c the covariance matrix corresponding to the linearly independent
30 c columns of a. to define the numerical rank of a, covar uses
31 c the tolerance tol. If l is the largest integer such that
32 c
33 c abs(r(l,l)) .gt. tol*abs(r(1,1)) ,
34 c
35 c then covar computes the covariance matrix corresponding to
36 c the first l columns of r. for k greater than l, column
37 c and row ipvt(k) of the covariance matrix are set to zero.
38 c
39 c the subroutine statement is
40 c
41 c subroutine covar(n,r,ldr,ipvt,tol,wa)
42 c
43 c
44 c where
45 c
46 c n is a positive integer input variable set to the order of r.
47 c
48 c r is an n by n array. on input, the full upper triangle must
49 c contain the full upper triangle of the matrix r. on
50 c output r contains the square symmetric covariance
51 c matrix.
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 tol is a nonnegative input variable used to define the
61 c numerical rank of a in the manner described above.
62 c
63 c wa is a work array of length n
64 c
65 c subprograms called
66 c
67 c fortran-supplied ... dabs
68 c
69 c argonne national laboratory. minpack project. march 1980.
70 c burton s. garbow, kenneth e. hillstrom, jorge j. more
71 c
72 c ***********
73 integer i,ii,j,jj,k,km1,l
74 logical sing
75 double precision one,temp,tolr,zero
76 data one,zero /1.0d0,0.0d0/
77 c
78 c----------------------------------------------------------------------
79 c form the inverse of r in the full upper triangle of r.
80 c----------------------------------------------------------------------
81 tolr = tol*dabs(r(1,1))
82 l = 0
83 do 40 k = 1, n
84 if (dabs(r(k,k)) .le. tolr) goto 50
85 r(k,k) = one/r(k,k)
86 km1 = k - 1
87 if (km1 .ge. 1) then
88 do 20 j = 1, km1
89 temp = r(k,k)*r(j,k)
90 r(j,k) = zero
91 do 10 i = 1, j
92 r(i,k) = r(i,k) - temp*r(i,j)
93 10 continue
94 20 continue
95 end if
96 l = k
97 40 continue
98 50 continue
99 c
100 c----------------------------------------------------------------------
101 c form the full upper triangle of the inverse of(r transpose)*r
102 c in the full upper triangle of r
103 c----------------------------------------------------------------------
104 if (l .ge. 1) then
105 do 100 k = 1, l
106 km1 = k - 1
107 if (km1 .ge. 1) then
108 do 70 j = 1, km1
109 temp = r(j,k)
110 do 60 i = 1, j
111 r(i,j) = r(i,j) + temp*r(i,k)
112 60 continue
113 70 continue
114 end if
115 temp = r(k,k)
116 do 90 i = 1, k
117 r(i,k) = temp*r(i,k)
118 90 continue
119 100 continue
120 c
121 end if
122 c
123 c----------------------------------------------------------------------
124 c form the full lower triangle of the covariance matrix
125 c in the strict lower triangle of r and in wa
126 c----------------------------------------------------------------------
127 do 130 j = 1, n
128 jj = ipvt(j)
129 sing = j .gt. l
130 do 120 i = 1, j
131 if (sing) r(i,j) = zero
132 ii = ipvt(i)
133 if (ii .gt. jj) r(ii,jj) = r(i,j)
134 if (ii .lt. jj) r(jj,ii) = r(i,j)
135 120 continue
136 wa(jj) = r(j,j)
137 130 continue
138 c
139 c----------------------------------------------------------------------
140 c symmetrize the covariance matrix in r.
141 c----------------------------------------------------------------------
142 do 150 j = 1, n
143 do 140 i = 1, j
144 r(i,j) = r(j,i)
145 140 continue
146 r(j,j) = wa(j)
147 150 continue
148 c
149 return
150 end
covar
subroutine covar(n, r, ldr, ipvt, tol, wa)
Definition: covar.f90:2