home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / eispack-1.0-src.tgz / tar.out / contrib / eispack / rsm.f < prev    next >
Text File  |  1996-09-28  |  3KB  |  73 lines
  1.       subroutine rsm(nm,n,a,w,m,z,fwork,iwork,ierr)
  2. c 
  3.       integer n,nm,m,iwork(n),ierr
  4.       integer k1,k2,k3,k4,k5,k6,k7
  5.       double precision a(nm,n),w(n),z(nm,m),fwork(1)
  6. c
  7. c     this subroutine calls the recommended sequence of
  8. c     subroutines from the eigensystem subroutine package (eispack)
  9. c     to find all of the eigenvalues and some of the eigenvectors
  10. c     of a real symmetric matrix.
  11. c
  12. c     on input
  13. c
  14. c        nm  must be set to the row dimension of the two-dimensional
  15. c        array parameters as declared in the calling program
  16. c        dimension statement.
  17. c
  18. c        n  is the order of the matrix  a.
  19. c
  20. c        a  contains the real symmetric matrix.
  21. c
  22. c        m  the eigenvectors corresponding to the first m eigenvalues
  23. c           are to be computed.
  24. c           if m = 0 then no eigenvectors are computed.
  25. c           if m = n then all of the eigenvectors are computed.
  26. c
  27. c     on output
  28. c
  29. c        w  contains all n eigenvalues in ascending order.
  30. c
  31. c        z  contains the orthonormal eigenvectors associated with
  32. c           the first m eigenvalues.
  33. c
  34. c        ierr  is an integer output variable set equal to an error
  35. c           completion code described in the documentation for tqlrat,
  36. c           imtqlv and tinvit.  the normal completion code is zero.
  37. c
  38. c        fwork  is a temporary storage array of dimension 8*n.
  39. c
  40. c        iwork  is an integer temporary storage array of dimension n.
  41. c
  42. c     questions and comments should be directed to burton s. garbow,
  43. c     mathematics and computer science div, argonne national laboratory
  44. c
  45. c     this version dated august 1983.
  46. c
  47. c     ------------------------------------------------------------------
  48. c
  49.       ierr = 10 * n
  50.       if (n .gt. nm .or. m .gt. nm) go to 50
  51.       k1 = 1
  52.       k2 = k1 + n
  53.       k3 = k2 + n
  54.       k4 = k3 + n
  55.       k5 = k4 + n
  56.       k6 = k5 + n
  57.       k7 = k6 + n
  58.       k8 = k7 + n
  59.       if (m .gt. 0) go to 10
  60. c     .......... find eigenvalues only ..........
  61.       call  tred1(nm,n,a,w,fwork(k1),fwork(k2))
  62.       call  tqlrat(n,w,fwork(k2),ierr)
  63.       go to 50
  64. c     .......... find all eigenvalues and m eigenvectors ..........
  65.    10 call  tred1(nm,n,a,fwork(k1),fwork(k2),fwork(k3))
  66.       call  imtqlv(n,fwork(k1),fwork(k2),fwork(k3),w,iwork,
  67.      x             ierr,fwork(k4))
  68.       call  tinvit(nm,n,fwork(k1),fwork(k2),fwork(k3),m,w,iwork,z,ierr,
  69.      x             fwork(k4),fwork(k5),fwork(k6),fwork(k7),fwork(k8))
  70.       call  trbak1(nm,n,a,fwork(k2),m,z)
  71.    50 return
  72.       end
  73.