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
|
SUBROUTINE MODAC2( NV,INP1,IOUT)
C
C MODAC2 REDUCES THE SIZE OF INP1 (BY REMOVING SELECTED COLUMNS)
C
C CORE IS LAIDED OUT AS FOLLOWS
C
C CONTENTS LENGTH TYPE POINTER
C -------- ------ ---- -------
C
C NEW TIMES NFN R IFN
C KEEP/REMOVE NFO I IKR
C COPIED COLUMN MCB(3) R ICOL
C
C 2 BUFFERS SYSBUF I IBUF1
C SYSBUF I IBUF2
C
C VARIABLES
C
C NV NUMBER OF COLUMS TO PROCESS TOGETHER (MINUS SAYS ADD HEAD
C INP1 COPY FROM THIS FILE
C IOUT COPY TO THIS FILE
C
C
C
INTEGER IZ,SYSBUF,NAME(2),IHD(2),MCB(7),FILE
REAL Z(1)
COMMON /UNPAKX/ITC,II,JJ,INCR
COMMON /SYSTEM/ SYSBUF
COMMON /MODAC3/ NFO,NFN,NZ
COMMON /ZZZZZZ/ IZ(1)
EQUIVALENCE (Z(1),IZ(1))
DATA NAME /4HMODA,4HC2 /
C
C ALLOCATE CORE
C
MCB(1) =IOUT
CALL RDTRL(MCB)
IF ( MCB(1) .LE. 0) RETURN
MCB(1) = INP1
CALL RDTRL(MCB)
IF (MCB(1) .LE. 0) RETURN
NLOAD = MCB(2)/(NFO*IABS(NV))
IFN =1
IKR = IFN + NFN
ICOL = IKR + NFO
IBUF1 = NZ -SYSBUF+1
IBUF2 = IBUF1- SYSBUF
IF ( ICOL + MCB(3) + 2*SYSBUF .GT. NZ) CALL MESAGE(-8,0,NAME)
C
C OPEN FILES
C
FILE = INP1
CALL GOPEN(INP1,IZ(IBUF1),0)
FILE = IOUT
CALL OPEN(*900,IOUT,IZ(IBUF2),1)
CALL FNAME(IOUT,IHD)
CALL WRITE(IOUT,IHD,2,0)
IF ( NV .GT. 0) GO TO 10
CALL WRITE(IOUT,Z,NFN,0)
10 CALL WRITE(IOUT,0,0,1)
C
C SET UP MATRIX TRAILER
C
FILE = INP1
MCB(2) =0
MCB(6) =0
MCB(7) =0
MCB(1) = IOUT
ITC = MCB(5)
INCR = 1
INV = IABS(NV)
DO 200 M = 1,NLOAD
K = IKR -1
DO 100 I =1,NFO
K =K+1
IF( IZ(K) .EQ. 0) GO TO 20
C
C KEEP COLUMN
C
CALL CYCT2B(INP1,IOUT,INV,IZ(ICOL),MCB)
GO TO 100
C
C SKIP COLUMN
C
20 DO 30 J = 1,INV
CALL FWDREC(*910,INP1)
30 CONTINUE
100 CONTINUE
200 CONTINUE
C
C CLOSE UP
C
CALL CLOSE(INP1,1)
CALL CLOSE(IOUT,1)
CALL WRTTRL(MCB)
RETURN
C
C ERROR MESSAGES
C
900 IP1= -1
901 CALL MESAGE(IP1,FILE,NAME)
910 IP1 = -2
GO TO 901
END
|
