1 SUBROUTINE qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa)
7 INTEGER,
INTENT(in) :: m, n, lda, lipvt
8 LOGICAL,
INTENT(in) :: pivot
9 INTEGER,
DIMENSION(lipvt),
INTENT(out) :: ipvt
10 REAL(rprec),
DIMENSION(lda,n),
INTENT(inout) :: a
11 REAL(rprec),
DIMENSION(n),
INTENT(out) :: rdiag, acnorm, wa
15 REAL(rprec),
PARAMETER :: one = 1, p05 = 0.05_dp,
20 INTEGER :: j, jp1, k, kmax, minmn
21 REAL(rprec) :: ajnorm, epsmch, sum0, temp, enorm, dpmpar
22 REAL(rprec) ,
ALLOCATABLE :: temp1u(:)
110 acnorm(j) = enorm(m,a(1,j))
113 IF (pivot) ipvt(j) = j
128 IF (rdiag(k) .gt. rdiag(kmax)) kmax = k
130 IF (kmax .ne. j)
THEN
133 a(:m,kmax) = temp1u(:m)
134 rdiag(kmax) = rdiag(j)
145 ajnorm = enorm(m-j+1,a(j,j))
146 IF (ajnorm .ne. zero)
THEN
147 IF (a(j,j) .lt. zero) ajnorm = -ajnorm
148 a(j:m,j) = a(j:m,j)/ajnorm
149 a(j,j) = a(j,j) + one
157 sum0 = sum(a(j:m,j)*a(j:m,k))
159 a(j:m,k) = a(j:m,k) - temp*a(j:m,j)
160 IF (pivot .and. rdiag(k).ne.zero)
THEN
161 temp = a(j,k)/rdiag(k)
162 rdiag(k) = rdiag(k)*sqrt(max(zero,one-temp**2))
163 IF (p05*(rdiag(k)/wa(k))**2 .le. epsmch)
THEN
164 rdiag(k) = enorm(m - j,a(jp1,k))