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
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
|
SUBROUTINE VALVEC
C
C LARGE ORDER REAL SYMMETRIC EIGENVALUE-EIGENVECTOR PROBLEM
C
INTEGER QR,MCB(8),TRI(3),QRX(3),WIL(3),VAL(3)
DIMENSION VCOM(30)
COMMON /ZZZZZZ/ A(1)
COMMON /GIVN / TITLE(150)
CWKBR 2/94 SPR93027 COMMON /SYSTEM/ ISYS
COMMON /SYSTEM/ ISYS, IDUMM(53), IPREC
EQUIVALENCE (MD ,TITLE(3)), (VCOM(1),TITLE(101)),
1 (N ,VCOM( 1)), (NV ,VCOM( 7)),
2 (OEIGS,VCOM(11)), (NVER ,VCOM( 13)),
3 (NEVER,VCOM(14)), (ITERM ,VCOM( 16))
DATA TRI / 4HTRID, 4HI , 4H /
DATA QRX / 4HQRIT, 4HER , 4H /
DATA WIL / 4HWILV, 4HEC , 4H /
DATA VAL / 4HVALV, 4HEC , 4H /
DATA IBEGN , IEND / 4HBEGN, 4HEND /
C
C DEFINITION OF VARIABLES AND DATA FORMATS
C
C MD INPUT MATRIX
C N SIZE OF MATRIX
C NV NUMBER OF EIGENVECTORS DESIRED
C OEIGS EIGENVALUE SUMMARY FILE
C A OPEN CORE
C ID POINTER TO DIAGONALS -- N OF THEM (D.P.)
C IO POINTER TO OFF-DIAGONALS -- N OF THEM (D.P.)
C IV POINTER TO EIGENVALUES -- N OF THEM (D.P.)
C IL POINTER TO ORDER FOUND ARRAY N OF THEM (S.P.)
C I1 - I6 POINTS TO SCRATCH ARRAYS -- 2XN LONG
C NVER NUMBER OF VECTORS ERRORS
C NEVER NUMBER OF EIGENVALUE ERRORS
C ITERM REASON FOR TERMINATION
C
C INITIALIZATION FOR VALVEC IN BLOCKDATA ROUTINE READBD
C
C DATA
C 1 MO, MD,MR1, M1, M2, M3, M4,LGAMA,OEIGS,PHIA,ORDER,RSTRT,NCOL,MAX/
C *301,304,202,303,307,308,309, 201, 204, 305, -2, 0 , 0,253/
C
C
VAL(3) = IBEGN
CALL CONMSG (VAL,3,0)
ITERM = 1
MCB(1) = MD
CALL RDTRL (MCB(1))
N = MCB(2)
N2 = N*IPREC
ID = 1
IO = ID + N2
IV = IO + N2
IL = IV + N2
I1 = IL + N
IF ((I1 + 1)/2 .EQ. I1/2) I1 = I1 + 1
I2 = I1 + N2
I3 = I2 + N2
I4 = I3 + N2
I5 = I4 + N2
I6 = I5 + N2
C
C TRIDIAGONALIZATION.
C
IF (N .GT. 2) GO TO 101
CWKBD 2/94 SPR93027 CALL SMLEIG (A(ID),A(IO),A(IV))
CWKBNB 2/94 SPR93027
IF ( IPREC .EQ. 2 ) CALL SMLEIG (A(ID),A(IO),A(IV))
IF ( IPREC .EQ. 1 ) CALL SMLEIG1(A(ID),A(IO),A(IV))
CWKBNE 2/94 SPR93027
IF (N-2) 300,200,300
101 TRI(3) = IBEGN
CALL CONMSG (TRI,3,0)
CWKBD 2/94 SPR93027 CALL TRIDI (A(ID),A(IO),A(IV),A(IL),A(I1),A(IL))
CWKBNB 2/94 SPR93027
IF ( IPREC .EQ. 2 )
&CALL TRIDI (A(ID),A(IO),A(IV),A(IL),A(I1),A(IL))
C D O V A B
IF ( IPREC .EQ. 1 )
&CALL TRIDI1(A(ID),A(IO),A(IV),A(IL),A(I1),A(IL))
C D O V A B
CWKBNE 2/94 SPR93027
TRI(3) = IEND
CALL CONMSG (TRI,3,0)
C
C EIGENVALUES
C
200 QR = 0
IF (N .LE. 2) QR = 1
QRX(3) = IBEGN
CALL CONMSG (QRX,3,0)
CWKBD 2/94 SPR93027 CALL QRITER (A(IV),A(I1),A(IL),QR)
CWKBNB 2/94 SPR93027
IF ( IPREC .EQ. 2 ) CALL QRITER (A(IV),A(I1),A(IL),QR)
IF ( IPREC .EQ. 1 ) CALL QRITER1(A(IV),A(I1),A(IL),QR)
CWKBNE 2/94 SPR93027
QRX(3) = IEND
CALL CONMSG (QRX,3,0)
RSTRT = 0
WIL(3) = IBEGN
CALL CONMSG (WIL,3,0)
C
C EIGENVECTORS
C
CWKBDB 2/94 SPR93027
C CALL WILVEC (A(ID),A(IO),A(IV),A(IL),A(I1),A(I2),A(I3),A(I4),
C 1 A(I5),A(I6),N,A(I6))
CWKBDE 2/94 SPR93027
CWKBNB 2/94 SPR93027
IF ( IPREC .EQ. 1 )
C D 0 C A B
&CALL WILVEC1(A(ID),A(IO),A(IV),A(IL),A(I1),A(I2),A(I3),A(I4),
& A(I5),A(I6),N,A(I6))
IF ( IPREC .EQ. 2 )
C D 0 C A B
&CALL WILVEC (A(ID),A(IO),A(IV),A(IL),A(I1),A(I2),A(I3),A(I4),
& A(I5),A(I6),N,A(I6))
CWKBNE 2/94 SPR93027
WIL(3) = IEND
CALL CONMSG (WIL,3,0)
300 CONTINUE
CALL GOPEN (OEIGS,A(1),1)
MCB(1) = 4
MCB(2) = N
MCB(3) = NV
MCB(4) = NEVER
MCB(5) = NVER
MCB(8) = ITERM
CALL WRITE (OEIGS,MCB,8,1)
CALL CLOSE (OEIGS,1)
VAL(3) = IEND
CALL CONMSG (VAL,3,0)
RETURN
END
|
