valpr.F File Reference

#include "implicit_f.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	valpr (a, r, n, mv)

Function/Subroutine Documentation

valpr()

subroutine valpr	(		a,
			r,
		integer	n,
		integer	mv )

Definition at line 29 of file valpr.F.

C-----------------------------------
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER N, MV
C     REAL
      my_real
     .   a(*), r(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER IQ, J, I, IJ, IA, IND, L, M, MQ, LQ, LM, LL, MM, ILQ, IMQ,
     .   IM, IL, ILR, IMR, JQ, K
C     REAL
      my_real
     .   range, anorm, anrmx, thr, x, y, sinx, sinx2, cosx, cosx2,
     .   sincs   
      range = 1.0e-7
      IF (mv/=1)THEN
        iq = -n
        DO j = 1,n
          iq = iq+n
          DO i = 1,n
            ij = iq+i
            r(ij) = zero
            IF (i==j)r(ij) = one
 
          ENDDO
        ENDDO
      ENDIF
      anorm = zero
      DO i = 1,n
        DO j = 1,n
          IF (i/=j) THEN
            ia = i+(j*j-j)/2
            anorm = anorm+a(ia)*a(ia)
          ENDIF
        ENDDO
      ENDDO
      IF (anorm<=zero) GOTO 300
      anorm = onep414*sqrt(anorm)
      anrmx = anorm*range/float(n)
      ind = 0
      thr = anorm
      thr = thr/float(n)
      l = 1
      m = l+1
C
  100 CONTINUE
C
      mq = (m*m-m)/2
      lq = (l*l-l)/2
      lm = l+mq
      IF (abs(a(lm))<thr) GOTO 200
      ind = 1
      ll = l+lq
      mm = m+mq
      x = half*(a(ll)-a(mm))
      y = -a(lm)/sqrt(a(lm)*a(lm)+x*x)
      IF (x<zero) THEN
       y = -y
      ELSEIF((x==zero).AND.(a(lm)<0)) THEN
       y = 1
      ELSEIF((x==zero).AND.(a(lm)>0)) THEN
       y = -1
      ENDIF
      sinx = y/sqrt(two*(one+(sqrt(abs(one-y*y)))))
      sinx2 = sinx*sinx
      cosx = sqrt(abs(one-sinx2))
      cosx2 = cosx*cosx
      sincs = sinx*cosx
      ilq = n*(l-1)
      imq = n*(m-1)
      DO i = 1,n
       iq = (i*i-i)/2
       IF (i/=l.AND.i/=m) THEN
        IF (i<m) THEN
          im = i+mq
        ELSE
          im = m+iq
        ENDIF
        IF (i>=l) THEN
          il = l+iq
        ELSE
          il = i+lq
        ENDIF
        x = a(il)*cosx-a(im)*sinx
        a(im) = a(il)*sinx+a(im)*cosx
        a(il) = x
       ENDIF
       IF (mv/=1) THEN
        ilr = ilq+i
        imr = imq+i
        x = r(ilr)*cosx-r(imr)*sinx
        r(imr) = r(ilr)*sinx+r(imr)*cosx
        r(ilr) = x
       ENDIF
      ENDDO
      x = two*a(lm)*sincs
      y = a(ll)*cosx2+a(mm)*sinx2-x
      x = a(ll)*sinx2+a(mm)*cosx2+x
      a(lm) = (a(ll)-a(mm))*sincs+a(lm)*(cosx2-sinx2)
      a(ll) = y
      a(mm) = x
C
  200 CONTINUE
C
      IF (m/=n) THEN
        m = m+1
        GO TO 100
      ENDIF
      IF (l/=(n-1)) THEN
        l = l+1
        m = l+1
        GO TO 100
      ENDIF
      IF (ind==1) THEN
        ind = 0
        l = 1
        m = l+1
        GO TO 100
      ENDIF
      IF (thr>anrmx) THEN
        thr = thr/float(n)
        l = 1
        m = l+1
        GO TO 100
      ENDIF
C
  300 CONTINUE
C
      iq = -n
C
      DO i = 1,n
        iq = iq+n
        ll = i+(i*i-i)/2
        jq = n*(i-2)
        DO j = i,n
          jq = jq+n
          mm = j+(j*j-j)/2
          IF (a(ll)<a(mm)) THEN
           x = a(ll)
           a(ll) = a(mm)
           a(mm) = x
           IF (mv/=1) THEN
            DO k = 1,n
             ilr = iq+k
             imr = jq+k
             x = r(ilr)
             r(ilr) = r(imr)
             r(imr) = x
            ENDDO
           ENDIF
          ENDIF
        ENDDO
      ENDDO
C
      anorm=sqrt(r(1)*r(1)+r(2)*r(2)+r(3)*r(3))
      r(1)=r(1)/anorm
      r(2)=r(2)/anorm
      r(3)=r(3)/anorm
      anorm=sqrt(r(4)*r(4)+r(5)*r(5)+r(6)*r(6))
      r(4)=r(4)/anorm
      r(5)=r(5)/anorm
      r(6)=r(6)/anorm
      r(7)=r(2)*r(6)-r(3)*r(5)
      r(8)=r(3)*r(4)-r(1)*r(6)
      r(9)=r(1)*r(5)-r(2)*r(4)
      anorm=sqrt(r(7)*r(7)+r(8)*r(8)+r(9)*r(9))
      r(7)=r(7)/anorm
      r(8)=r(8)/anorm
      r(9)=r(9)/anorm
C
      RETURN