1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
|
SUBROUTINE EVEC_SHIFT(EIGEN, VEC, SCR, NOPT)
IMPLICIT DOUBLE PRECISION (A-H, O-Z)
DIMENSION EIGEN(NOPT, NOPT), VEC(NOPT, NOPT), SCR(NOPT, NOPT)
C
#ifdef _DEBUG_LVL0
Write(6,"(a)") "Unsorted Eigen values and vectors"
call output(eigen, 1, nopt, 1, nopt, nopt, nopt, 1)
call output(vec, 1, nopt, 1, nopt, nopt, nopt, 1)
#endif
NTR=0
DO I=NOPT,1,-1
IF(ABS(EIGEN(I,I)).LT.1.0D-09) NTR=NTR+1
IF(ABS(EIGEN(I,I)).LT.1.0D-09) ISHIFT=I
ENDDO
C
JSHIFT=ISHIFT-1
DO J=1,NTR
JSHIFT=JSHIFT+1
SCR(8,J)=EIGEN(JSHIFT,JSHIFT)
DO I=1,NOPT
SCR(J,I)=VEC(I,JSHIFT)
ENDDO
ENDDO
C
DO J=ISHIFT,NOPT-NTR
EIGEN(J,J)=EIGEN(J+NTR,J+NTR)
DO I=1,NOPT
VEC(I,J)=VEC(I,J+NTR)
ENDDO
ENDDO
C
JTMP=0
DO J=NOPT-NTR+1,NOPT
JTMP=JTMP+1
EIGEN(J,J)=SCR(8,JTMP)
DO I=1,NOPT
VEC(I,J)=SCR(JTMP,I)
ENDDO
ENDDO
C
#ifdef _DEBUG_LVL0
Write(6,"(a)") "Sorted Eigen values and vectors"
call output(eigen, 1, nopt, 1, nopt, nopt, nopt, 1)
call output(vec, 1, nopt, 1, nopt, nopt, nopt, 1)
#endif
RETURN
END
|
