Initial commit

dataassim/math/numrec/f77_sources/tred2.for

@@ -0,0 +1,83 @@
+      SUBROUTINE tred2(a,n,np,d,e)
+      INTEGER n,np
+      REAL a(np,np),d(np),e(np)
+      INTEGER i,j,k,l
+      REAL f,g,h,hh,scale
+      do 18 i=n,2,-1
+        l=i-1
+        h=0.
+        scale=0.
+        if(l.gt.1)then
+          do 11 k=1,l
+            scale=scale+abs(a(i,k))
+11        continue
+          if(scale.eq.0.)then
+            e(i)=a(i,l)
+          else
+            do 12 k=1,l
+              a(i,k)=a(i,k)/scale
+              h=h+a(i,k)**2
+12          continue
+            f=a(i,l)
+            g=-sign(sqrt(h),f)
+            e(i)=scale*g
+            h=h-f*g
+            a(i,l)=f-g
+            f=0.
+            do 15 j=1,l
+C     Omit following line if finding only eigenvalues
+              a(j,i)=a(i,j)/h
+              g=0.
+              do 13 k=1,j
+                g=g+a(j,k)*a(i,k)
+13            continue
+              do 14 k=j+1,l
+                g=g+a(k,j)*a(i,k)
+14            continue
+              e(j)=g/h
+              f=f+e(j)*a(i,j)
+15          continue
+            hh=f/(h+h)
+            do 17 j=1,l
+              f=a(i,j)
+              g=e(j)-hh*f
+              e(j)=g
+              do 16 k=1,j
+                a(j,k)=a(j,k)-f*e(k)-g*a(i,k)
+16            continue
+17          continue
+          endif
+        else
+          e(i)=a(i,l)
+        endif
+        d(i)=h
+18    continue
+C     Omit following line if finding only eigenvalues.
+      d(1)=0.
+      e(1)=0.
+      do 24 i=1,n
+C     Delete lines from here ...
+        l=i-1
+        if(d(i).ne.0.)then
+          do 22 j=1,l
+            g=0.
+            do 19 k=1,l
+              g=g+a(i,k)*a(k,j)
+19          continue
+            do 21 k=1,l
+              a(k,j)=a(k,j)-g*a(k,i)
+21          continue
+22        continue
+        endif
+C     ... to here when finding only eigenvalues.
+        d(i)=a(i,i)
+C     Also delete lines from here ...
+        a(i,i)=1.
+        do 23 j=1,l
+          a(i,j)=0.
+          a(j,i)=0.
+23      continue
+C     ... to here when finding only eigenvalues.
+24    continue
+      return
+      END