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
|
SUBROUTINE READ7 (NR1,OLAMA,OPHIA,NLAMA,NPHIA)
C
C READ7 COPIES NR VECTORS FROM OPHIA TO NPHIA -
C IT ALSO PLACES THE EIGENVALUES ON NLAMA
C THIS ROUTINE HANDLES BOTH SINGLE AND DOUBLE PRECISION
C
INTEGER OLAMA,OPHIA,SYSBUF,IX(7),NAME(2),SGLDBL
REAL X(7)
DOUBLE PRECISION DCORE(2),DX
COMMON /SYSTEM/ SYSBUF
COMMON /UNPAKX/ ITB,II,JJ,INCUR
COMMON /PACKX / IT1,IT2,IIP,JJP,INCRP
COMMON /ZZZZZZ/ CORE(1)
EQUIVALENCE (DCORE(1),CORE(1)) , (X(1),DX)
DATA NAME / 4HREAD,4H7 /
C
C GET ORGANIZED
C
NR = NR1
LC = KORSZ(CORE)
IBUF1 = LC - SYSBUF + 1
IBUF2 = IBUF1 -SYSBUF
IBUF3 = IBUF2 -SYSBUF
IBUF4 = IBUF3 -SYSBUF
IX(1) = OPHIA
CALL RDTRL (IX)
NROW = IX(3)
II = 1
JJ = NROW
IT1 = IX(5)
IT2 = IT1
ITB = IT1
DCORE(1) = 0.0D0
INCRP = 1
ASSIGN 12 TO SGLDBL
IF (ITB .EQ. 2) ASSIGN 16 TO SGLDBL
INCUR = 1
C
C OPEN OLD FILES
C
CALL GOPEN (OLAMA,CORE(IBUF1),0)
CALL FWDREC (*3010,OLAMA)
CALL GOPEN (OPHIA,CORE(IBUF2),0)
C
C OPEN NEW FILES TO WRITE
C
CALL GOPEN (NLAMA,CORE(IBUF3),1)
CALL GOPEN (NPHIA,CORE(IBUF4),1)
C
C START COPY LOOP
C
CALL MAKMCB (IX,NPHIA,NROW,IX(4),IT2)
DO 10 I = 1,NR
CALL READ (*3010,*3020,OLAMA,X,7,0,IFL)
II = 0
CALL UNPACK (*150,OPHIA,DCORE(2))
GO TO SGLDBL, (12,16)
12 X(1) = SQRT(X(6))
DO 14 J = 1,NROW
14 CORE(J+2) = CORE(J+2)/X(1)
GO TO 20
16 DX = SQRT(X(6))
DO 18 J = 1,NROW
18 DCORE(J+1) = DCORE(J+1)/DX
20 IIP = II
JJP = JJ
CALL PACK (DCORE(2),NPHIA,IX)
30 DX = X(3)
CALL WRITE (NLAMA,DX,2,1)
GO TO 10
C
C NULL COLUMN
C
150 IIP = 1
JJP = 1
CALL PACK (DCORE,NPHIA,IX)
GO TO 30
10 CONTINUE
CALL CLOSE (OLAMA,1)
CALL CLOSE (OPHIA,1)
CALL CLOSE (NLAMA,2)
CALL CLOSE (NPHIA,1)
RETURN
C
C ERRORS
C
3010 NN = -2
3012 IFILE = OLAMA
CALL MESAGE (NN,IFILE,NAME)
RETURN
3020 NN = -3
GO TO 3012
END
|
