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
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
|
SUBROUTINE TABPCH
C
C THE TABPCH MODULE WILL PUNCH UP TO 5 TABLES INTO DTI CARDS
C
C DMAP CALL IS
C
C TABPCH IN1,IN2,IN3,IN4,IN5//P1,P2,P3,P4,P5
C
C SINGLE FIELD CARDS WILL BE MADE UNLESS REAL NUMBERS ARE TO BE MADE
C ALL REAL NUMBERS ARE ASSUMED TO BE SINGLE PRECISION.
C
C LAST REVISED, 3/93, BY G.CHAN/UNISYS
C PUNCH KELM, MELM AND BELM IN D.P. IF THESE DATA BLOCKS ARE IN D.P.
C
C $MIXED_FORMATS
C
INTEGER SYSBUF ,IZ(10) ,IFNM(5) ,NAME(2) ,
1 MCB(7) ,FILE ,TABNM(2) ,DTI(2) ,
2 DTIS(2) ,IDATA(20) ,ENDREC(2) ,OUT ,
3 IFORM(20) ,BLANK ,INT(2) ,IREAL(2) ,
4 LL(4) ,INTD(2) ,PFORM(30) ,IBCD(2) ,
5 SP(3) ,IBCDD(2) ,FORM(30,2),FORMS(30,2)
REAL RDATA(20)
DOUBLE PRECISION DZ(1)
CHARACTER UFM*23 ,UWM*25 ,UIM*29
COMMON /XMSSG / UFM ,UWM ,UIM
COMMON /MACHIN/ MACH
COMMON /SYSTEM/ SYSBUF ,OUT ,KSYSTM(88),LPCH
COMMON /ZZZZZZ/ Z(1)
COMMON /BLANK / N1(2,5)
EQUIVALENCE (Z(1),IZ(1),DZ(1)), (IDATA(1),RDATA(1))
DATA BLANK / 1H /
DATA DTI / 4HDTI , 1H /
DATA DTIS / 4HDTI*, 1H /
DATA ENDREC/ 4HENDR, 4HEC /
DATA FORMS / 4H(2A4, 26*2H ,4H,1H+ ,4HA2,I, 4H5) , 4H(A1,,
1 4HA2,I ,4H5 ,24*2H ,4H,1H+, 4HA2,I, 4H5) /
DATA IBCD / 4H,2A4, 1H /
DATA IBCDD / 4H,2A4, 4H,8X /
DATA IFNM / 101, 102, 103, 104, 105/
DATA INT / 4H,I8 , 1H /
DATA INTD / 4H,I16, 1H /
DATA IPLUS / 1H+ /
DATA IREAL / 4H,E16, 4H.9 /
DATA ISTAR / 1H* /
DATA NAME / 4HTABP, 4HCH /
DATA LL / 1, 1, 3, 2 /
DATA NSP , SP / 3, 4HKELM, 4HMELM, 4HBELM /
C
NZ = KORSZ(Z)
IBUF = NZ - SYSBUF + 1
NZ = IBUF - 1
ICRQ = 10 - NZ
IF (NZ .LE. 10) GO TO 830
NREAD = NZ/2 - 2
NLIST = NREAD + 3
DO 10 J = 1,2
DO 10 I = 1,30
FORM(I,J) = FORMS(I,J)
10 CONTINUE
C
C FOR EACH TABLE DEFINED
C
NS = -1
DO 720 I = 1,5
MCB(1) = IFNM(I)
CALL RDTRL (MCB)
IF (MCB(1) .LE. 0) GO TO 720
C
C TABLE EXISTS SET IT UP
C
FILE = IFNM(I)
CALL OPEN (*800,FILE,IZ(IBUF),0)
CALL FNAME (FILE,TABNM)
IO = 0
KMB = 4
IF (MCB(5).EQ.1 .OR. MCB(5).EQ.3) GO TO 40
DO 20 J = 1,NSP
IF (KMB.EQ.1 .OR. TABNM(1).NE.SP(J)) GO TO 20
KMB = 1
IO = 1
NREAD = NZ -1
20 CONTINUE
IF (NS .NE. -1) GO TO 40
NS = 1
CALL PAGE1
WRITE (OUT,30) UWM
30 FORMAT (A25,', MODULE TABPCH ASSUMES ALL REAL DATA ARE IN S.P..',
1 ' D.P. DATA THEREFORE MAY BE PUNCHED ERRONEOUSLY')
IF (MACH.EQ.5 .OR. MACH.EQ.6 .OR. MACH.EQ.10 .OR. MACH.EQ.21)
1 WRITE (OUT,35)
35 FORMAT (4X,'(ALL INTEGERS EXCEEDING 16000 ARE PUNCHED AS REAL ',
1 'NUMBERS. ALL REAL NUMBERS OUTSIDE E-27 OR E+27 RANGE ',
2 'ARE PUNCHED AS INTEGERS)')
C
40 CALL READ (*810,*820,FILE,IZ(1),-2,0,ILEN)
IRECNO = 0
ICHR = N1(1,I)
IZ(3) = 0
C
C SET UP FIRST RECORD
C
IZ(1) = TABNM(1)
IZ(2) = TABNM(2)
IZ(4) = MCB(2)
IZ(5) = MCB(3)
IZ(6) = MCB(4)
IZ(7) = MCB(5)
IZ(8) = MCB(6)
IZ(9) = MCB(7)
CALL READ (*700,*50,FILE,IZ(10),NREAD,0,ILEN)
ICRQ = NREAD
GO TO 830
50 ILEN = ILEN + 11
60 IZ(ILEN-1) = ENDREC(1)
IZ(ILEN ) = ENDREC(2)
GO TO 90
C
C BRING IN NEXT RECORD
C
70 CALL READ (*700,*80,FILE,IZ(KMB),NREAD,IO,ILEN)
ICRQ = NREAD
GO TO 830
80 IF (KMB .EQ. 1) GO TO 600
IZ(3) = IZ(3) + 1
IF (ILEN .EQ. 0) GO TO 70
ILEN = ILEN + 5
GO TO 60
C
C BUILD FORMAT VECTOR 1= INTEGER, 2 =BCD, 3=REAL
C
90 JV = 3
DO 100 K = 1,ILEN
M = NLIST + K - 1
J = NUMTYP(IZ(K))
IF (J.EQ.0 .AND. JV.NE.3) J = JV
IZ(M) = LL(J+1)
100 JV = J
C
C MOVE DATA/FORMAT TO DATA AREA 8 FIELDS AT A TIME--SET D.F. FLAG
C
ID = 1
IF = NLIST
IFRS = 1
C
C HERE FOR EIGHT MORE WORDS
C
110 IDF = 0
IDT = 1
IFT = 1
NF = 1
C
C HERE FOR EACH FIELD
C
120 IDATA(IDT) = IZ(ID)
IFORM(IFT) = IZ(IF)
IF (IFORM(IFT) .EQ. 3) IDF = 1
IF (IFORM(IFT) .NE. 2) GO TO 140
C
C BCD IS TWO WORDS
C
IDATA(IDT+1) = IZ(ID+1)
C
C MAY BE FALSE BCD, CHECK FORMAT OF SECOND WORD ALSO
C (SOME REAL NUMBER BIT PATTERNS LOOK LIKE BCD).
C
IF (IZ(IF+1) .EQ. 2) GO TO 130
C
C SECOND WORD IS NOT BCD, ASSUME FIRST WORD IS REAL.
C
IDF = 1
IFORM(IFT) = 3
GO TO 140
130 IDT = IDT + 2
IFT = IFT + 1
ID = ID + 2
IF = IF + 2
GO TO 150
C
C REAL OR INTEGER
C
140 IDT = IDT + 1
IFT = IFT + 1
ID = ID + 1
IF = IF + 1
C
C BUMP FIELD COUNTER
C
150 NF = NF + 1
IF (NF .GT. 8) GO TO 160
IF (ID .LT. ILEN) GO TO 120
C
C FILL WITH BLANKS
C
IDATA(IDT ) = BLANK
IDATA(IDT+1) = BLANK
IFORM(IFT ) = 2
GO TO 130
C
C PUNCH OUT 8 FIELDS OF DATA
C
160 IDT = 0
IF (IDF .NE. 0) GO TO 400
C
C SINGLE FIELD CARD
C
NF = 1
170 M = 2*NF + 2
IF (IFORM(NF)-2) 180,200,210
C
C INTEGER
C
180 FORM(M ,IFRS) = INT(1)
FORM(M+1,IFRS) = INT(2)
C
C GET NEXT ITEM
C
IDT = IDT + 1
190 NF = NF + 1
IF (NF .LE. 8) GO TO 170
GO TO 220
C
C BCD
C
200 FORM(M ,IFRS) = IBCD(1)
FORM(M+1,IFRS) = IBCD(2)
IDT = IDT + 2
GO TO 190
C
C REAL NOT LEGAL
C
210 IP1 = -37
GO TO 850
C
C PUNCH OUT SINGLE CARD
C
220 IF (IFRS .NE. 1) GO TO 270
DO 230 J = 1,30
PFORM(J) = FORM(J,1)
230 CONTINUE
WRITE (LPCH,PFORM,ERR=240) DTI,(RDATA(M),M=1,IDT),ICHR,IRECNO
240 IRECNO = IRECNO + 1
IFRS = 2
DO 250 J = 1,30
250 FORM(J,1) = FORMS(J,1)
260 IF (ID .GE. ILEN) GO TO 70
GO TO 110
C
C CONTINUATION CARD
C
270 IRCNM1 = IRECNO - 1
DO 280 J = 1,30
PFORM(J) = FORM(J,2)
280 CONTINUE
WRITE (LPCH,PFORM,ERR=290) IPLUS,ICHR,IRCNM1,(RDATA(M),M=1,IDT),
1 ICHR,IRECNO
290 IRECNO = IRECNO + 1
DO 300 J = 1,30
300 FORM(J,2) = FORMS(J,2)
GO TO 260
C
C DOUBLE FIELD CARDS
C
400 NF = 1
IS = 1
IT = 4
IDT= 0
M = 2
410 M = M + 2
IF (IFORM(NF)-2) 420,450,460
C
C INTEGER
C
420 FORM(M ,IFRS) = INTD(1)
FORM(M+1,IFRS) = INTD(2)
430 IDT = IDT + 1
440 NF = NF + 1
IF (M .LE. 8) GO TO 410
GO TO 470
C
C BCD
C
450 FORM(M ,IFRS) = IBCDD(1)
FORM(M+1,IFRS) = IBCDD(2)
IDT = IDT + 2
GO TO 440
C
C REAL
C
460 FORM(M ,IFRS) = IREAL(1)
FORM(M+1,IFRS) = IREAL(2)
GO TO 430
C
C PUNCH OUT DOUBLE FIELD CARD
C
470 IF (IFRS .NE. 1) GO TO 520
DO 480 J = 1,30
PFORM(J) = FORM(J,1)
480 CONTINUE
WRITE (LPCH,PFORM,ERR=490) DTIS,(RDATA(M),M=IS,IDT),ICHR,IRECNO
490 IRECNO = IRECNO + 1
DO 500 J = 1,30
500 FORM(J,1) = FORMS(J,1)
IFRS = 2
510 IT = 8
M = 2
IS = IDT + 1
GO TO 410
C
C CONTINUATION CARD
C
520 IRCNM1 = IRECNO - 1
DO 530 J = 1,30
PFORM(J) = FORM(J,2)
530 CONTINUE
WRITE (LPCH,PFORM,ERR=540) ISTAR,ICHR,IRCNM1,(RDATA(M),M=IS,IDT),
1 ICHR,IRECNO
540 IRECNO = IRECNO + 1
DO 550 J = 1,30
550 FORM(J,2) = FORMS(J,2)
IF (IT .EQ. 4) GO TO 510
GO TO 260
C
C PUNCH KELM, MELM AND BELM IN D.P.
C
600 IF (ILEN .EQ. 0) GO TO 70
ILEN = ILEN/2
JE = 0
610 JB = JE + 1
JE = JE + 4
IRCNM1 = IRECNO
IRECNO = IRECNO + 1
IF (JE .GE. ILEN) GO TO 630
WRITE (LPCH,620,ERR=840) ICHR,IRCNM1,(DZ(J),J=JB,JE),ICHR,IRECNO
620 FORMAT (1H*,A2,I5,1P,4D16.9,1X,A2,I5)
GO TO 610
630 JE = ILEN
WRITE (LPCH,640,ERR=840) ICHR,IRCNM1,(DZ(J),J=JB,JE)
640 FORMAT (1H*,A2,I5,1P,4D16.9)
GO TO 70
C
C CLOSE OFF FILES
C
700 CALL CLOSE (FILE,1)
CALL PAGE2 (2)
WRITE (OUT,710) UIM,TABNM,IRECNO
710 FORMAT (A29,' 4015, TABLE ',2A4,' WAS PUNCHED OUT,',I8,' CARDS.')
720 CONTINUE
WRITE (LPCH,730)
730 FORMAT (1H , /,1H , /,1H )
RETURN
C
C ERROR MESAGES
C
800 IP1 = -1
GO TO 850
810 IP1 =-2
GO TO 850
820 IP1 =-3
GO TO 850
830 IP1 = -8
FILE = ICRQ
GO TO 850
840 IP1 = -37
C
850 CALL MESAGE (IP1,FILE,NAME)
RETURN
END
|
