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
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
|
SUBROUTINE ASPRO (DMAP,VAR,NVAR,OBITS,SOL)
C
C THIS CODE PERFORMS THE ROUTINE PROCESSING OF THE DMAP ALTERS
C FOR ASDMAP. KEY TABLES ARE-
C
C DMAP - RAW 18 WORD PER CARD BCD DATA ON INPUT, VARIABLE
C CHARACTERS ARE ADDED AND FIELDS AND CARDS ARE DELETED
C DEPENDING ON USER INPUT IN VAR(IABLE) AND OPTION FLAGS.
C
C VAR CONTROL DATA AND USER INPUT DATA, 3 WORDS, BCD + DATA
C
C PTBS POSITIONS-TO-BE-SET TABLE, CONTENTS-PER ENTRY
C
C 1 CARD NUMBER IN DMAP
C 2 FIRST CHARACTER OF MODIFIED FIELD
C 3 FIRST CHARACTER FOR ADDED VARIABLE
C 4 NUMBER OF VARIABLE CHARACTERS
C 5 KEY OF VARIABLE TO BE INSERTED
C 6 MATRIX OPTION FLAG , 1= K, 2=M, 4=P ETC
C 7 OUTPUT CONTROL FLAG, AVOIDS SAME DATA BLOCK
C OUTPUT FROM TWO MODULES
C
C OCT OPTIONAL CARDS TABLE - EACH ENTRY =
C DMAP CARD NO. , DELETE BITS , KEEP BITS
C
C OBITS - BITS ARE ON FOR REQUIRED MATRICES = SUM OF NUMBERS
C K=1 , M=2 , P=4 , PA=8 , B=16 , K4=32
C
EXTERNAL ANDF
LOGICAL RMV,RMVALL
INTEGER ANDF,DBS(2,50),DMAP(18,1),FLAG,II(2),NAME(4),
1 OBITS,OCT(3,50),PTBS(7,200),VAR(3,200),VWORD,SOL,
2 ALTER,BLANK,AST,SLAS,OBALL,RFMASK(40)
CHARACTER UFM*23,UWM*25,UIM*29,SFM*25
COMMON /XMSSG / UFM,UWM,UIM,SFM
COMMON /ASDBD / IRDM,NRDM,IXTRA,NXTRA,IOCT,NOCT,IPTBS,NPTBS,
1 IPH,NPH,IDAT(1)
COMMON /ZZZZZZ/ SBD(2)
COMMON /SYSTEM/ IDUM1,IOUT,NOGO
EQUIVALENCE (NDBS,SBD(1)),(DBS(1,1),SBD(2))
DATA ALTER / 4HALTE /, BLANK / 4H /
DATA AST / 4H* /, SLAS / 4H/ /
DATA RFMASK/ 65536,131072,262144,0,0,0,0,524288,1048576,31*0 /
DATA OBALL / 63 /
C
RMVALL = .TRUE.
NXDEL = 0
NOLD = 0
C
C DELETE CARDS USING OCT TABLE.
C
IF (NOCT .EQ. 0) GO TO 45
M = IOCT - 1
DO 10 J = 1,NOCT
DO 10 I = 1,3
M = M + 1
OCT(I,J) = IDAT(M)
10 CONTINUE
DO 40 I = 1,NOCT
ICD = OCT(1,I)
IF (OCT(3,I) .EQ. 0) GO TO 20
IF (ANDF(OCT(3,I),OBITS) .EQ. 0) GO TO 35
20 IF (ANDF(OCT(2,I),RFMASK(SOL)) .EQ. 0) GO TO 40
35 DMAP(1,ICD) = -1
40 CONTINUE
45 IF (NPTBS .EQ. 0) GO TO 2000
M = IPTBS - 1
DO 46 J = 1,NPTBS
DO 46 I = 1,7
M = M + 1
PTBS(I,J) = IDAT(M)
46 CONTINUE
DO 1000 I = 1,NPTBS
ICD = PTBS(1,I)
IF (DMAP(1,ICD) .EQ. -1) GO TO 1000
IF (ICD .EQ. 0) GO TO 1000
RMV = .FALSE.
C
C CHECK IF OPTION IS ON
C
KOPT = PTBS(6,I)
IF (ANDF(KOPT,OBITS) .EQ. 0) RMV = .TRUE.
IF (ANDF(KOPT,OBALL) .EQ. 0) RMV = .FALSE.
IF (ANDF(KOPT,RFMASK(SOL)) .NE. 0) RMV = .TRUE.
NCHAR = PTBS(4,I)
NC = 0
FLAG = 0
VWORD = BLANK
ICOL = PTBS(3,I)
C
C FIND VARIABLE IF REQUIRED
C
IF (RMV) GO TO 300
KEY = PTBS(5,I)
I3 = NVAR/3
DO 60 J = 1,I3
IF (VAR(1,J) .EQ. KEY) GO TO 70
IF (KEY.EQ.J .AND. VAR(1,J).EQ.ALTER) GO TO 450
60 CONTINUE
C
C VARIABLE HAS NOT BEEN SET
C
VWORD = BLANK
RMV = .TRUE.
GO TO 300
C
C VARIABLE IS FOUND , IT IS IN VAR(2,J) AND/OR VAR(3,J)
C
70 VWORD = VAR(2,J)
NAME(1) = VAR(2,J)
NAME(2) = VAR(3,J)
C
C TEST FOR REAL OR INTEGER
C
IF (VWORD .EQ. 0) GO TO 300
IF (VWORD .EQ. -1) GO TO 74
IF (VWORD .EQ. -2) GO TO 3010
C
C WORD IS REAL (TEMPORARY ERROR)
C
GO TO 75
C
C WORD IS AN INTEGER
C
74 NAME(1) = NAME (2)
NAME(2) = 0
FLAG = 1
75 IF (PTBS(7,I) .EQ. 0) GO TO 500
NC = PTBS(3,I) - PTBS(2,I)
II(1) = BLANK
II(2) = BLANK
IF (NC .GT. 0) GO TO 80
IF (NC .LT. 0) GO TO 3010
II(1) = NAME(1)
II(2) = NAME(2)
GO TO 100
C
C CONSTRUCT WHOLE DATA BLOCK NAME
C
80 CALL PULL (DMAP(1,ICD),II,PTBS(2,I),NC,0)
CALL PUSH (NAME,II,NC+1,NCHAR,FLAG)
C
C CHECK OUTPUT DATA BLOCKS AGAINST PREVIOUS OUTPUTS
C
100 IF (NDBS .EQ. 0) GO TO 142
C
DO 140 L = 1, NDBS
IF (II(1).EQ.DBS(1,L) .AND. II(2).EQ.DBS(2,L)) GO TO 150
140 CONTINUE
142 IF (PTBS(7,I) .GT. 0) GO TO 200
C
C VARIABLE IS OK , ADD NAME TO LIST
C
NDBS = NDBS + 1
DBS(1,NDBS) = II(1)
DBS(2,NDBS) = II(2)
GO TO 500
150 IF (PTBS(7,I) .GT. 0) GO TO 500
C
C DATA BLOCK IS OUTPUT, REMOVE IF ALLREADY DEFINED.
C
200 RMV =.TRUE.
C
C REMOVE WHOLE NAME HERE , CHECK FOR PARAMETER
C
300 II(1) = 0
NAME(1) = BLANK
NAME(2) = BLANK
NAME(3) = BLANK
NAME(4) = BLANK
FLAG = 0
CALL PULL (DMAP(1,ICD),II,PTBS(2,I),1,0)
IF (II(1).EQ.SLAS .OR. II(1).EQ.AST) GO TO 500
ICOL = PTBS(2,I)
NCHAR = NCHAR + PTBS(3,I) - PTBS(2,I)
GO TO 500
C
C CHECK IF ALTER CARD, OUTPUT AS BCD AND TWO INTEGERS
C
450 DMAP(1,ICD) = ALTER
DMAP(2,ICD) = VAR(2,J)
DMAP(3,ICD) = VAR(3,J)
RMVALL = .FALSE.
NXDEL = 0
IF (VAR(2,J) .EQ. 0) RMVALL = .TRUE.
GO TO 910
C
C ADD VARIABLES TO BCD DMAP
C
500 CALL PUSH (NAME,DMAP(1,ICD),ICOL,NCHAR,FLAG)
C
IF (.NOT.RMV) RMVALL = .FALSE.
C
C IF ALL VARIABLES ARE REMOVED FROM ONE CARD, DELETE THE CARD
C
NNEW = PTBS(1,I+1)
IF (ICD .EQ. NNEW) GO TO 1000
C
C NEXT COMMAND GOES TO NEW CARD, CHECK IF CONTINUATION
C
905 CALL PULL (DMAP(1,ICD+1),II,1,4,0)
C
IF (II(1) .NE. BLANK) GO TO 910
C
C CONTINUATION FOUND
C
NXDEL = NXDEL + 1
IF (NNEW .EQ. ICD+1) GO TO 1000
ICD = ICD+1
GO TO 905
C
C FINISHED WITH LOGICAL CARD
C
910 IF (.NOT.RMVALL) GO TO 940
DMAP(1,ICD) = -1
IF (NXDEL .LE. 0) GO TO 1000
DO 930 L = 1,NXDEL
J = ICD-L
DMAP(1,J) = -1
930 CONTINUE
940 RMVALL = .TRUE.
C
C END OF LOOP ON VARIABLE CHARACTERS
C
NXDEL = 0
C
1000 CONTINUE
C
C PROCESS CARDS TO BE DELETED FROM SEQUENCE
C
2000 IKEEP = 0
DO 2500 ICD = 1,NRDM
C
IF (DMAP(1,ICD) .EQ. -1) GO TO 2500
C
C KEEP CARD
C
IKEEP = IKEEP + 1
DO 2450 J = 1,18
DMAP(J,IKEEP) = DMAP(J,ICD)
2450 CONTINUE
2500 CONTINUE
NRDM = IKEEP
RETURN
3010 WRITE (IOUT,3020) SFM,DMAP(1,ICD)
3020 FORMAT (A25,' 6010, ILLEGAL VARIABLE TO BE SET IN DMAP STATEMENT',
1 3X,A4)
C
NOGO = 1
RETURN
END
|
