c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine diagq  --  fast matrix diagonalization routine  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "diagq" is a matrix diagonalization routine which is a
c     conglomeration of the classical given, housec, and eigen
c     algorithms with several modifications to increase the
c     efficiency and accuracy
c
c     n         logical dimension of the matrix to be diagonalized
c     np        physical dimension of the matrix storage area
c     nv        number of eigenvalues and eigenvectors desired
c     dd        upper triangle of the matrix to be diagonalized
c     ev        returned with the eigenvalues in ascending order
c     vec       returned with the eigenvectors of the matrix
c     a,b,p,w,
c     ta,tb,y   temporary work vectors of dimension (np+1)
c
c     this routine is adapted from an original program written by
c     Bernie Brooks, DCRT, National Inst. of Health, Bethesda, MD
c
c
      subroutine diagq (n,np,nv,dd,ev,vec,a,b,p,w,ta,tb,y)
      implicit none
      include 'inform.i'
      include 'iounit.i'
      integer i,j,k,m,n,ia,ii,ji,mi,mj,mk
      integer nn,nm,np,nv,nom,nomtch,ntot
      integer ipt,iter,j1,mi1,mj1,mk1
      real*8 alimit,anorm,aroot,bx,del1,delbig,delta
      real*8 elapsed,elim1,elim2,epr,eta,expr,factor
      real*8 f0,gamma,rand1,rootl,rootx,rpow1,rpower
      real*8 s,sgn,sum1,t,temp,theta,theta1,toler
      real*8 trial,u,xkap,xnorm
      real*8 dd(np*(np+1)/2),vec(np,np),ev(np)
      real*8 a(np+1),b(np+1),p(np+1),w(np+1)
      real*8 ta(np+1),tb(np+1),y(np+1)
      logical done
c
c
c     initialization and setup of the problem
c
      if (verbose)  call setime
      eta = 1.0d-16
      theta = 1.0d37
      del1 = eta / 100.0d0
      delta = eta**2 * 100.0d0
      gamma = eta**2 / 100.0d0
      delbig = theta*delta / 1000.0d0
      theta1 = 1000.0d0 / theta
      toler = 100.0d0 * eta
      rpower = 8388608.0d0
      rpow1 = rpower * 0.5d0
      rand1 = rpower - 3.0d0
      factor = 0.0d0
      ntot = n*(n+1) / 2
      do i = 1, ntot
         factor = max(factor,abs(dd(i)))
      end do
      if (factor .eq. 0.0d0)  return
      k = 0
      anorm = 0.0d0
      do i = 1, n
         do j = i, n
            k = k + 1
            u = (dd(k)/factor)**2
            if (i .eq. j)  u = u * 0.5d0
            anorm = anorm + u
         end do
      end do
      anorm = sqrt(anorm+anorm) * factor
      do i = 1, ntot
         dd(i) = dd(i) / anorm
      end do
      if (verbose) then
         call getime (elapsed)
         write (iout,10)  elapsed
   10    format (' DIAGQ  --  Time for Initial Setup :',f13.2)
         call setime
      end if
c
c     perform the tridiagonalization step
c
      nn = n - 1
      mi = 0
      mi1 = n - 1
      do i = 1, nn
         sum1 = 0.0d0
         b(i) = 0.0d0
         ji = i + 1
         ipt = mi + i
         a(i) = dd(ipt)
         ipt = ipt + 1
         bx = dd(ipt)
         if (ji .eq. n) then
            b(i) = bx
            dd(mi+ji) = 0.0d0
            mi = mi + mi1
            mi1 = mi1 - 1
         else
            do j = ji+1, n
               ipt = ipt + 1
               sum1 = sum1 + dd(ipt)*dd(ipt)
            end do
            if (sum1 .gt. gamma) then
               s = sqrt(sum1+bx**2)
               sgn = 1.0d0
               if (bx .lt. 0.0)  sgn = -1.0d0
               temp = abs(bx)
               w(ji) = sqrt(0.5d0*(1.0d0+(temp/s)))
               ipt = mi + ji
               dd(ipt) = w(ji)
               ii = i + 2
               if (ii .le. n) then
                  temp = sgn/(2.0d0*w(ji)*s)
                  do j = ii, n
                     ipt = ipt + 1
                     w(j) = temp * dd(ipt)
                     dd(ipt) = w(j)
                  end do
               end if
               b(i) = -sgn * s
               do j = ji, n
                  p(j) = 0.0d0
               end do
               mk = mi + mi1
               mk1 = mi1 - 1
               do k = ji, n
                  ipt = mk + k
                  do m = k, n
                     bx = dd(ipt)
                     p(k) = p(k) + bx*w(m)
                     if (k .ne. m)  p(m) = p(m) + bx*w(k)
                     ipt = ipt + 1
                  end do
                  mk = mk + mk1
                  mk1 = mk1 - 1
               end do
               xkap = 0.0d0
               do k = ji, n
                  xkap = xkap + w(k)*p(k)
               end do
               do k = ji, n
                  p(k) = p(k) - xkap*w(k)
               end do
               mj = mi + mi1
               mj1 = mi1 - 1
               do j = ji, n
                  do k = j, n
                     expr = p(j)*w(k) + p(k)*w(j)
                     dd(mj+k) = dd(mj+k) - expr - expr
                  end do
                  mj = mj + mj1
                  mj1 = mj1 - 1
               end do
               mi = mi + mi1
               mi1 = mi1 - 1
            end if
         end if
      end do
      if (verbose) then
         call getime (elapsed)
         write (iout,20)  elapsed
   20    format (' DIAGQ  --  Time to Tridiagonalize :',f13.2)
         call setime
      end if
c
c     find the eigenvalues of the matrix
c
      a(n) = dd(mi+n)
      b(n) = 0.0d0
      alimit = 1.0d0
      do i = 1, n
         w(i) = b(i)
         b(i) = b(i) * b(i)
      end do
      do i = 1, nv
         ev(i) = alimit
      end do
      rootl = -alimit
      do i = 1, nv
         rootx = alimit
         do j = i, nv
            rootx = min(rootx,ev(j))
         end do
         ev(i) = rootx
   30    continue
         trial = (rootl+ev(i)) * 0.5d0
         if (trial.ne.rootl .and. trial.ne.ev(i)) then
            nomtch = n
            j = 1
   40       continue
            f0 = a(j) - trial
   50       continue
            if (abs(f0) .ge. theta1) then
               if (f0 .ge. 0.0d0)  nomtch = nomtch-1
               j = j + 1
               if (j .gt. n)  goto 60
               f0 = a(j) - trial - b(j-1)/f0
               goto 50
            end if
            j = j + 2
            nomtch = nomtch - 1
            if (j .le. n)  goto 40
   60       continue
            if (nomtch .lt. i) then
               rootl = trial
            else
               ev(i) = trial
               nom = min(nv,nomtch)
               ev(nom) = trial
            end if
            goto 30
         end if
      end do
      if (verbose) then
         call getime (elapsed)
         write (iout,70)  elapsed
   70    format (' DIAGQ  --  Time for Eigenvalues :',f15.2)
         call setime
      end if
c
c     find the eigenvectors of the matrix
c
      do i = 1, nv
         aroot = ev(i)
         do j = 1, n
            y(j) = 1.0d0
         end do
         if (i.eq.1 .or. abs(ev(i-1)-aroot).ge.toler) then
            ia = 0
         else
            ia = ia + 1
         end if
         elim1 = a(1) - aroot
         elim2 = w(1)
         do j = 1, nn
            if (abs(elim1) .gt. abs(w(j))) then
               ta(j) = elim1
               tb(j) = elim2
               p(j) = 0.0d0
               temp = w(j) / elim1
               elim1 = a(j+1) - aroot - temp*elim2
               elim2 = w(j+1)
            else
               ta(j) = w(j)
               tb(j) = a(j+1) - aroot
               p(j) = w(j+1)
               temp = 1.0d0
               if (abs(w(j)) .gt. theta1)  temp = elim1 / w(j)
               elim1 = elim2 - temp*tb(j)
               elim2 = -temp * w(j+1)
            end if
            b(j) = temp
         end do
         ta(n) = elim1
         tb(n) = 0.0d0
         p(n) = 0.0d0
         p(nn) = 0.0d0
         iter = 1
         if (ia .ne. 0)  goto 100
   80    continue
         m = n + 1
         do j = 1, n
            m = m - 1
            done = .false.
            dowhile (.not. done)
               done = .true.
               if (n-m-1 .lt. 0) then
                  elim1 = y(m)
               else
                  if (n-m-1 .eq. 0) then
                     elim1 = y(m) - y(m+1)*tb(m)
                  else
                     elim1 = y(m) - y(m+1)*tb(m) - y(m+2)*p(m)
                  end if
               end if
               if (abs(elim1) .le. delbig) then
                  temp = ta(m)
                  if (abs(temp) .lt. delta)  temp = delta
                  y(m) = elim1 / temp
               else
                  do k = 1, n
                     y(k) = y(k) / delbig
                  end do
                  done = .false.
               end if
            end do
         end do
         if (iter .eq. 2)  goto 110
         iter = iter + 1
   90    continue
         elim1 = y(1)
         do j = 1, nn
            if (ta(j) .ne. w(j)) then
               y(j) = elim1
               elim1 = y(j+1) - elim1*b(j)
            else
               y(j) = y(j+1)
               elim1 = elim1 - y(j+1)*b(j)
            end if
         end do
         y(n) = elim1
         goto 80
  100    continue
         do j = 1, n
            rand1 = mod(4099.0d0*rand1,rpower)
            y(j) = rand1/rpow1 - 1.0d0
         end do
         goto 80
  110    continue
         if (ia .ne. 0) then
            do j1 = 1, ia
               k = i - j1
               temp = 0.0d0
               do j = 1, n
                  temp = temp + y(j)*vec(j,k)
               end do
               do j = 1, n
                  y(j) = y(j) - temp*vec(j,k)
               end do
            end do
         end if
         if (iter .eq. 1)  goto 90
         elim1 = 0.0d0
         do j = 1, n
            elim1 = max(elim1,abs(y(j)))
         end do
         temp = 0.0d0
         do j = 1, n
            elim2 = y(j) / elim1
            temp = temp + elim2*elim2
         end do
         temp = 1.0d0 / (sqrt(temp)*elim1)
         do j = 1, n
            y(j) = y(j) * temp
            if (abs(y(j)) .lt. del1)  y(j) = 0.0d0
         end do
         do j = 1, n
            vec(j,i) = y(j)
         end do
      end do
      if (verbose) then
         call getime (elapsed)
         write (iout,120)  elapsed
  120    format (' DIAGQ  --  Time for Eigenvectors :',f14.2)
         call setime
      end if
c
c     perform the transformation step
c
      do i = 1, nv
         do j = 1, n
            y(j) = vec(j,i)
         end do
         mk = (n*(n-1))/2 - 3
         mk1 = 3
         nm = n - 2
         do j = 1, nm
            t = 0.0d0
            m = n - j
            do k = m, n
               t = t + dd(mk+k)*y(k)
            end do
            do k = m, n
               epr = t * dd(mk+k)
               y(k) = y(k) - 2.0d0*epr
            end do
            mk = mk - mk1
            mk1 = mk1 + 1
         end do
         t = 0.0d0
         do j = 1, n
            t = t + y(j)*y(j)
         end do
         xnorm = sqrt(t)
         do j = 1, n
            y(j) = y(j) / xnorm
         end do
         do j = 1, n
            vec(j,i) = y(j)
         end do
      end do
      do i = 1, n
         ev(i) = ev(i) * anorm
      end do
      if (verbose) then
         call getime (elapsed)
         write (iout,130)  elapsed
  130    format (' DIAGQ  --  Time for Transformation :',f12.2)
      end if
      return
      end
