NLSL
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