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
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
|
SUBROUTINE READ4 (LAMA,PHI,SCR1,EPS,MASS)
C
C READ4 WILL TEST FOR CLOSE AND EQUAL ROOTS AND MAKE SURE THE
C CORRESPONDING VECTORS ARE ORTHOGONAL
C
INTEGER NAME(2) ,PHI(7) ,RSP ,PHI1(7)
INTEGER RDREW ,WRTREW
CWKBI ALPHA-OSF 9/94
INTEGER SCR1
DOUBLE PRECISION DZ(1)
CHARACTER UFM*23 ,UWM*25
COMMON /XMSSG / UFM ,UWM
COMMON /ZZZZZZ/ Z(1)
COMMON /SYSTEM/ KSYSTM(65)
COMMON /NAMES / RD ,RDREW ,WRT ,WRTREW ,
1 REW ,NOREW ,EOFNRW ,RSP
COMMON /UNPAKX/ ITYPE ,IUNPAK ,JUNPAK ,INCR
COMMON /PACKX / ITYPA ,ITYPB ,IPAK ,JPAK ,
1 INCRX
EQUIVALENCE (KSYSTM(1),ISYS) ,(KSYSTM(2),IOUT) ,
1 (DZ(1),Z(1))
DATA NAME / 4HREAD,4H4 /
C
NCOL = PHI(2)
NROW = PHI(3)
NZ = KORSZ(Z)
IBUF = NZ - ISYS
IBUF1 = IBUF - ISYS
IBUF2 = IBUF1 - ISYS
ICLOS = 0
IDID = 0
IPR = PHI(5)
RMULT = .01
ITYPE = RSP
IUNPAK= 1
JUNPAK= NROW
INCR = 1
ITYPA = RSP
ITYPB = RSP
IPAK = 1
JPAK = NROW
INCRX = 1
EPSI = EPS
IF (EPS .LE. 0.) EPSI = .0001
NZ = NZ - ISYS - ISYS - 1 - ISYS
CALL MAKMCB (PHI1,SCR1,NROW,2,RSP)
IFILE = LAMA
CALL GOPEN (LAMA,Z(IBUF),0)
CALL READ (*170,*10,LAMA,Z(1),NZ,1,N)
GO TO 180
10 CALL CLOSE (LAMA,REW)
C
C REJECT ALL BUT VALUES FOR WHICH VECTORS EXIST
C
N = PHI(2)
NZ = NZ -N
IF (NZ .LT. NROW) GO TO 180
IFILE = PHI(1)
CALL GOPEN (PHI,Z(IBUF),0)
IPOS = 1
I = 1
EPS1 = RMULT
20 CONTINUE
IF (ABS(Z(I))+ABS(Z(I+1)) .LT. EPS1) GO TO 1111
IF (Z(I+1) .EQ. 0.0) GO TO 110
IF (ABS(1.0-Z(I)/Z(I+1)) .GT. EPS1) GO TO 100
1111 IF (ICLOS .NE. 0) GO TO 110
ICLOS = I
GO TO 110
30 NUM = I - ICLOS + 1
EPS1 = RMULT
C
C NUM = NUMBER OF CLOSE ROOTS IN THIS GROUP
C ICLOS = THE INDEX OF THE FIRST CLOSE ROOT
C
IF (IDID .EQ. 1) GO TO 40
IDID = 1
IFILE = SCR1
CALL GOPEN (SCR1,Z(IBUF1),WRTREW)
40 II = N + 1
50 IF (IPOS .EQ. ICLOS) GO TO 70
IFILE = PHI(1)
CALL UNPACK (*190,PHI,Z(II))
CALL PACK (Z(II),SCR1,PHI1)
IPOS = IPOS + 1
GO TO 50
70 CONTINUE
C
C CHECK FOR CORE OVERFLOW
C EIGENVALUES + EIGENVECTORS + GEN. MASS + ACCUM.
C
KORE = II + NUM*NROW + NUM*NUM + N + N + 3
IF (KORE .GT. NZ) GO TO 160
DO 80 J = 1,NUM
CALL UNPACK (*190,PHI,Z(II))
IPOS = IPOS + 1
II = II + NROW
IF (II+NROW .GE. NZ) GO TO 180
80 CONTINUE
IJ = II + N + N + 3
II = II/2 + 1
CALL ORTCK (Z(N+1),MASS,Z(IBUF2),NUM,NROW,Z(IJ),DZ(II),EPSI)
II = N + 1
DO 90 J = 1,NUM
CALL PACK (Z(II),SCR1,PHI1)
90 II = II + NROW
ICLOS = 0
100 IF (ICLOS .NE. 0) GO TO 30
110 I = I + 1
IF (I .LT. N) GO TO 20
IF (ICLOS .NE. 0) GO TO 30
IF (IDID .EQ. 0) GO TO 150
IF (IPOS .GT. NCOL) GO TO 121
DO 120 I = IPOS,NCOL
CALL UNPACK (*190,PHI,Z)
CALL PACK (Z(1),SCR1,PHI1)
120 CONTINUE
121 CALL WRTTRL (PHI1)
C
C COPY VECTORS FROM SCR1 TO PHI
C
CALL CLOSE (PHI,REW)
CALL CLOSE (SCR1,REW)
CALL GOPEN (PHI,Z(IBUF),1)
CALL GOPEN (SCR1,Z(IBUF1),RDREW )
CALL MAKMCB (PHI,PHI,NROW,2,IPR)
ITYPB = IPR
DO 140 I = 1,N
CALL UNPACK (*190,SCR1,Z)
CALL PACK (Z,PHI,PHI)
140 CONTINUE
CALL WRTTRL (PHI)
CALL CLOSE (SCR1,REW)
150 CALL CLOSE (PHI,REW)
RETURN
C
160 EPS2 = EPS1/10.
WRITE (IOUT,165) UWM,NUM,I,EPS1,EPS2
165 FORMAT (A25,' 3142, INSUFFICIENT CORE STORAGE FOR EIGENVECTORS ',
1 'ASSOCIATED WITH',I4,' MULTIPLE EIGENVALUES STARTING WITH',
2 /28X,'MODE NUMBER',I4,' USING CURRENT MULTIPLE ROOT ',
3 'CRITERIA. CRITERIA REDUCED FROM ',1P,E12.5,' TO ',E12.5)
EPS1 = EPS2
I = ICLOS
GO TO 20
170 NO = -2
GO TO 200
180 NO = -8
GO TO 200
190 NO = -7
200 CALL MESAGE (NO,IFILE,NAME)
RETURN
END
|
