Initial commit

2016-02-03 18:52:05 +00:00
commit d40505e161
507 changed files with 91383 additions and 0 deletions
@@ -0,0 +1,92 @@
+      SUBROUTINE jacobi(a,n,np,d,v,nrot)
+      INTEGER n,np,nrot,NMAX
+      REAL a(np,np),d(np),v(np,np)
+      PARAMETER (NMAX=500)
+      INTEGER i,ip,iq,j
+      REAL c,g,h,s,sm,t,tau,theta,tresh,b(NMAX),z(NMAX)
+      do 12 ip=1,n
+        do 11 iq=1,n
+          v(ip,iq)=0.
+11      continue
+        v(ip,ip)=1.
+12    continue
+      do 13 ip=1,n
+        b(ip)=a(ip,ip)
+        d(ip)=b(ip)
+        z(ip)=0.
+13    continue
+      nrot=0
+      do 24 i=1,50
+        sm=0.
+        do 15 ip=1,n-1
+          do 14 iq=ip+1,n
+            sm=sm+abs(a(ip,iq))
+14        continue
+15      continue
+        if(sm.eq.0.)return
+        if(i.lt.4)then
+          tresh=0.2*sm/n**2
+        else
+          tresh=0.
+        endif
+        do 22 ip=1,n-1
+          do 21 iq=ip+1,n
+            g=100.*abs(a(ip,iq))
+            if((i.gt.4).and.(abs(d(ip))+
+     *g.eq.abs(d(ip))).and.(abs(d(iq))+g.eq.abs(d(iq))))then
+              a(ip,iq)=0.
+            else if(abs(a(ip,iq)).gt.tresh)then
+              h=d(iq)-d(ip)
+              if(abs(h)+g.eq.abs(h))then
+                t=a(ip,iq)/h
+              else
+                theta=0.5*h/a(ip,iq)
+                t=1./(abs(theta)+sqrt(1.+theta**2))
+                if(theta.lt.0.)t=-t
+              endif
+              c=1./sqrt(1+t**2)
+              s=t*c
+              tau=s/(1.+c)
+              h=t*a(ip,iq)
+              z(ip)=z(ip)-h
+              z(iq)=z(iq)+h
+              d(ip)=d(ip)-h
+              d(iq)=d(iq)+h
+              a(ip,iq)=0.
+              do 16 j=1,ip-1
+                g=a(j,ip)
+                h=a(j,iq)
+                a(j,ip)=g-s*(h+g*tau)
+                a(j,iq)=h+s*(g-h*tau)
+16            continue
+              do 17 j=ip+1,iq-1
+                g=a(ip,j)
+                h=a(j,iq)
+                a(ip,j)=g-s*(h+g*tau)
+                a(j,iq)=h+s*(g-h*tau)
+17            continue
+              do 18 j=iq+1,n
+                g=a(ip,j)
+                h=a(iq,j)
+                a(ip,j)=g-s*(h+g*tau)
+                a(iq,j)=h+s*(g-h*tau)
+18            continue
+              do 19 j=1,n
+                g=v(j,ip)
+                h=v(j,iq)
+                v(j,ip)=g-s*(h+g*tau)
+                v(j,iq)=h+s*(g-h*tau)
+19            continue
+              nrot=nrot+1
+            endif
+21        continue
+22      continue
+        do 23 ip=1,n
+          b(ip)=b(ip)+z(ip)
+          d(ip)=b(ip)
+          z(ip)=0.
+23      continue
+24    continue
+      pause 'too many iterations in jacobi'
+      return
+      END