c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###########################################################
c     ##                                                       ##
c     ##  subroutine qrfact  --  QR factorization of a matrix  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "qrfact" performs Householder transformations with column
c     pivoting (optional) to compute a QR factorization of the
c     m by n matrix a; the routine determines an orthogonal
c     matrix q, a permutation matrix p, and an upper trapezoidal
c     matrix r with diagonal elements of nonincreasing magnitude,
c     such that a*p = q*r; the Householder transformation for
c     column k, k = 1,2,...,min(m,n), is of the form
c
c               i - (1/u(k))*u*u(transpose)
c
c     where u has zeros in the first k-1 positions
c
c     arguments and variables :
c
c     m        positive integer input variable set to
c                the number of rows of a
c     n        positive integer input variable set to
c                the number of columns of a
c     a        m by n array; on input a contains the matrix for
c                which the QR factorization is to be computed; on
c                output the strict upper trapezoidal part contains
c                the strict upper trapezoidal part of r, the lower
c                trapezoidal part contains a factored form of q
c                (non-trivial elements of u vectors described above)
c     lda      positive integer input variable not less than m
c                which specifies the leading dimension of array a
c     pivot    logical input variable; if pivot is set true,
c                then column pivoting is enforced; if pivot is
c                set false, then no column pivoting is done
c     ipvt     integer output array which defines the permutation
c                matrix p such that a*p = q*r; column j of p is
c                column ipvt(j) of the identity matrix
c     rdiag    an output array of length n which contains
c                the diagonal elements of r
c
c
      subroutine qrfact (m,n,a,lda,pivot,ipvt,rdiag,work)
      implicit none
      integer m,n,lda,ipvt(n)
      integer i,j,k,jmax,minmn,itemp
      real*8 aknorm,temp,a(lda,n),rdiag(n),work(n)
      logical pivot
c
c
c     find the initial column norms and initialize some arrays
c
      do j = 1, n
         temp = 0.0d0
         do i = 1, m
            temp = temp + a(i,j)**2
         end do
         rdiag(j) = sqrt(temp)
         work(j) = rdiag(j)
         if (pivot)  ipvt(j) = j
      end do
c
c     reduce the matrix with Householder transformations
c
      minmn = min(m,n)
      do k = 1, minmn
c
c     bring the column of largest norm into the pivot position
c
         if (pivot) then
            jmax = k
            do j = k, n
               if (rdiag(j) .gt. rdiag(jmax))  jmax = j
            end do
            if (jmax .ne. k) then
               do i = 1, m
                  temp = a(i,k)
                  a(i,k) = a(i,jmax)
                  a(i,jmax) = temp
               end do
               rdiag(jmax) = rdiag(k)
               work(jmax) = work(k)
               itemp = ipvt(k)
               ipvt(k) = ipvt(jmax)
               ipvt(jmax) = itemp
            end if
         end if
c
c     compute the Householder transformation to reduce the
c     k-th column of a to a multiple of the k-th unit vector
c
         aknorm = 0.0d0
         do i = k, m
            aknorm = aknorm + a(i,k)**2
         end do
         aknorm = sqrt(aknorm)
         if (aknorm .ne. 0.0d0) then
            if (a(k,k) .lt. 0.0d0)  aknorm = -aknorm
            do i = k, m
               a(i,k) = a(i,k) / aknorm
            end do
            a(k,k) = a(k,k) + 1.0d0
c
c     apply the transformation to the remaining columns
c     and update the column norms
c
            if (n .ge. k+1) then
               do j = k+1, n
                  temp = 0.0d0
                  do i = k, m
                     temp = temp + a(i,k)*a(i,j)
                  end do
                  temp = temp / a(k,k)
                  do i = k, m
                     a(i,j) = a(i,j) - temp*a(i,k)
                  end do
                  if (pivot .and. rdiag(j).ne.0.0d0) then
                     temp = a(k,j) / rdiag(j)
                     if (abs(temp) .lt. 1.0d0) then
                        rdiag(j) = rdiag(j) * sqrt(1.0d0-temp**2)
                     else
                        temp = 0.0d0
                        do i = k+1, m
                           temp = temp + a(i,j)**2
                        end do
                        rdiag(j) = sqrt(temp)
                        work(j) = rdiag(j)
                     end if
                  end if
               end do
            end if
         end if
         rdiag(k) = -aknorm
      end do
      return
      end
