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
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
|
SUBROUTINE TABFMT
C
C MODULE MAIN PROGRAM FOR DMAP MODULE TABPRT
C
C THE CALL TO THIS MODULE IS
C
C TABPRT TDB // C,N,KEY / C,N,OPT1 / C,N,OPT2 $
C
C TDB IS THE TABLE DATA BLOCK TO BE PRINTED.
C
C KEY IS THE BCD VALUE WHICH DETERMINES THE FORMAT BY
C WHICH THE TABLE IS PRINTED.
C THERE IS NO DEFAULT VALUE FOR KEY.
C
C OPT1 IS A SKIP FACTOR BETWEEN DATA LINES.
C OPT1.EQ.0 MEANS NO SPACE BETWEEN DATA LINES.
C OPT1.NE.0 MEANS ONE SPACE BETWEEN DATA LINES.
C THE DEFAULT VALUE FOR OPT1 IS 0
C
C OPT2 IS ZERO BY DEFAULT.
C SKIP FILE-NAME AND KEY CHECKING IF OPT2 IS NON-ZERO.
C
INTEGER P,P2,P3,NA,R,X(14),SUBNAM(2),NAME(2),NONE(2),
1 NAM(2),RE,F,T(7),WD,RL,Y,Z(2),EID,A,B,
2 H1,H2,H3,HX,ZERO,ONE,TWO
REAL RX(14)
CHARACTER UFM*23,UWM*25
COMMON /XMSSG / UFM,UWM
COMMON /BLANK / P(2),P2,P3
COMMON /SYSTEM/ NB,NO,JUNK1(6),NLPP,JUNK2(2),LINE
COMMON /OUTPUT/ T1(32),T2(32),T3(32),H1(32),H2(32),H3(32)
COMMON /TABFTX/ LA,NA(2,21) , HX(32,40) , RE(21)
COMMON /ZZZZZZ/ IX(1)
EQUIVALENCE (RX(1),X(1),IX(1))
DATA NONE / 4H (NO , 4HNE) /
DATA SUBNAM/ 4HTABF , 4HMT /
DATA F / 101 /
DATA ZERO / 4H 0 /, ONE / 4H 1 / , TWO / 4H 2 /
C
C
1 FORMAT (1H )
C
LC = KORSZ(X) - NB
IB = LC + 1
IF (LC .LE. 0) CALL MESAGE (-8,LC,SUBNAM)
LS = 1
IF (P2 .NE. 0) LS = 2
C
DO 100 I = 1,LA
IF (P(1).EQ.NA(1,I) .AND. P(2).EQ.NA(2,I)) GO TO 200
100 CONTINUE
GO TO 9901
C
200 CONTINUE
CALL FNAME (F,NAME)
IF (NAME(1).EQ.NONE(1) .AND. NAME(2).EQ.NONE(2)) GO TO 9902
T(1) = F
CALL RDTRL (T)
IF (T(1) .LE. 0) GO TO 9902
CALL OPEN (*9902,F,X(IB),0)
CALL READ (*9903,*9904,F,NAM,2,RE(I),KF)
IF (NAM(1).EQ.P(1) .AND. NAM(2).EQ.P(2)) GO TO 250
IF (P3 .EQ. 0) GO TO 9901
250 CONTINUE
C
GO TO (1100,1200,1300,1400,1500,1600,1700,1800,1900,2000
1 ,2100,2200,2300,2400,2500,2600,2700,2800,2900,3000
2 ,3100), I
C
C PRINT CONTENTS OF TABLE DATA BLOCK BGPDT.
C
1100 CONTINUE
M1 = 2
M2 = 3
M3 = 4
ASSIGN 1110 TO R
GO TO 8000
1110 CONTINUE
H1(19) = P(1)
H1(20) = P(2)
H1(24) = ONE
IF (LC .LT. 4) GO TO 9905
J = 0
1120 CALL READ (*9903,*1180,F,X,4,0,KF)
J = J + 1
LINE = LINE + LS
IF (LINE .LE. NLPP) GO TO 1140
CALL PAGE
WRITE (NO,1)
LINE = LS
1140 IF (P2 .NE. 0) WRITE (NO,1)
WRITE (NO,1150) J,X(1),(RX(L),L=2,4)
1150 FORMAT (20X,I10,I13,1X,1P,3E20.5)
GO TO 1120
1180 CONTINUE
IF (KF .EQ. 0) GO TO 9000
GO TO 9906
C
C PRINT CONTENTS OF TABLE DATA BLOCK GPL.
C
1200 CONTINUE
C
C RECORD 1
C
M1 = 2
M2 = 5
M3 = 6
ASSIGN 1205 TO R
GO TO 8000
1205 CONTINUE
H1(19) = P(1)
H1(20) = P(2)
H1(24) = ONE
IF (LC .LT. 5) GO TO 9905
J = -4
1210 CALL READ (*9903,*1230,F,X,5,0,KF)
J = J + 5
LINE = LINE + LS
IF (LINE.LE.NLPP) GO TO 1220
CALL PAGE
WRITE (NO,1)
LINE = LS
1220 IF (P2 .NE. 0) WRITE (NO,1)
WRITE (NO,1225) J,(X(L),L=1,5)
1225 FORMAT (11X,I8,5(9X,I8,3X))
GO TO 1210
1230 CONTINUE
IF (KF .EQ. 0) GO TO 1250
J = J + 5
LINE = LINE + LS
IF (LINE .LE. NLPP) GO TO 1240
CALL PAGE
WRITE (NO,1)
LINE = LS
1240 IF (P2 .NE. 0) WRITE (NO,1)
WRITE (NO,1225) J,(X(L),L=1,KF)
C
C RECORD 2
C
1250 IF (I .EQ. 4) GO TO 9000
M1 = 2
M2 = 7
M3 = 8
ASSIGN 1255 TO R
GO TO 8000
1255 CONTINUE
H1(19) = P(1)
H1(20) = P(2)
H1(24) = TWO
IF (LC .LT. 6) GO TO 9905
J = -2
1260 CALL READ (*9903,*1280,F,X,6,0,KF)
J = J + 3
LINE = LINE + LS
IF (LINE .LE. NLPP) GO TO 1270
CALL PAGE
WRITE (NO,1)
LINE = LS
1270 IF (P2 .NE. 0) WRITE (NO,1)
WRITE (NO,1275) J,(X(L),L=1,6)
1275 FORMAT (11X,I8,2X,3(9X,I8,4X,I12))
GO TO 1260
1280 CONTINUE
IF (KF .EQ. 0) GO TO 1292
J = J + 3
LINE = LINE + LS
IF (LINE .LE. NLPP) GO TO 1290
CALL PAGE
WRITE (NO,1)
LINE = LS
1290 IF (P2 .NE. 0) WRITE (NO,1)
WRITE (NO,1275) J,(X(L),L=1,KF)
C
1292 IF (MOD(KF,2) .EQ. 0) GO TO 9000
GO TO 9906
C
C PRINT CONTENTS OF TABLE DATA BLOCK CSTM
C
1300 CONTINUE
M1 = 2
M2 = 9
M3 = 10
ASSIGN 1310 TO R
GO TO 8000
1310 CONTINUE
H1(19) = P(1)
H1(20) = P(2)
H1(24) = ONE
IF (LC .LT. 14) GO TO 9905
J = 0
1320 CALL READ (*9903,*1380,F,X,14,0,KF)
J = J + 1
LINE = LINE + LS + 2
IF (LINE .LE. NLPP) GO TO 1340
CALL PAGE
WRITE (NO,1)
LINE = LS + 2
1340 IF (P2 .NE. 0) WRITE (NO,1)
WRITE (NO,1350) J,X(1),X(2),RX( 6),RX( 7),RX( 8),RX( 3)
1 ,RX( 9),RX(10),RX(11),RX( 4)
2 ,RX(12),RX(13),RX(14),RX( 5)
1350 FORMAT( 10X,I10,I10,I10, 1P,3E20.8,10X,1P,E20.8
1 /40X, 1P,3E20.8,10X,1P,E20.8
2 /40X, 1P,3E20.8,10X,1P,E20.8)
GO TO 1320
1380 CONTINUE
IF (KF .EQ. 0) GO TO 9000
GO TO 9906
C
C PRINT CONTENTS OF TABLE DATA BLOCK GPLD
C
1400 CONTINUE
GO TO 1200
C
C PRINT CONTENTS OF TABLE DATA BLOCK EQEXIN
C
1500 CONTINUE
M1 = 2
M2 = 11
M3 = 12
ASSIGN 1501 TO R
GO TO 8000
1501 CONTINUE
H1(19) = P(1)
H1(20) = P(2)
H1(24) = ONE
1502 IF (LC .LT. 8) GO TO 9905
J = -3
1510 CALL READ (*9903,*1530,F,X,8,0,KF)
J = J + 4
LINE = LINE + LS
IF (LINE .LE. NLPP) GO TO 1520
CALL PAGE
WRITE (NO,1)
LINE = LS
1520 IF (P2 .NE. 0) WRITE (NO,1)
WRITE (NO,1525) J,(X(L),L=1,8)
1525 FORMAT (7X,I8,4(7X,I8,6X,I8))
GO TO 1510
1530 CONTINUE
IF (KF .EQ. 0) GO TO 1550
J = J + 4
LINE = LINE + LS
IF (LINE .LE. NLPP) GO TO 1540
CALL PAGE
WRITE (NO,1)
LINE = LS
1540 IF (P2 .NE. 0) WRITE (NO,1)
WRITE (NO,1525) J,(X(L),L=1,KF)
C
C RECORD 2
C
1550 IF (H1(24) .EQ. TWO) GO TO 9000
M1 = 2
M2 = 11
M3 = 22
ASSIGN 1555 TO R
GO TO 8000
1555 CONTINUE
H1(19) = P(1)
H1(20) = P(2)
H1(24) = TWO
GO TO 1502
C
C PRINT CONTENTS OF TABLE DATA BLOCK EQDYN
C
1600 CONTINUE
GO TO 1500
C
C PRINT CONTENTS OF TABLE DATA BLOCK GPDT
C
1700 CONTINUE
M1 = 2
M2 = 13
M3 = 14
ASSIGN 1710 TO R
GO TO 8000
1710 CONTINUE
H1(19) = P(1)
H1(20) = P(2)
H1(24) = ONE
IF (LC .LT. 7) GO TO 9905
J = 0
1720 CALL READ (*9903,*1750,F,X,7,0,KF)
J = J + 1
LINE = LINE + LS
IF (LINE .LE. NLPP) GO TO 1730
CALL PAGE
WRITE (NO,1)
LINE = LS
1730 IF (P2 .NE. 0) WRITE (NO,1)
WRITE (NO,1740) X(1),X(2),RX(3),RX(4),RX(5),X(6),X(7)
1740 FORMAT (7X,I8,10X,I8,10X,3(1P,E12.5,5X),5X,I8,10X,I8)
GO TO 1720
1750 CONTINUE
IF (KF .EQ. 0) GO TO 9000
GO TO 9906
C
C PRINT CONTENTS OF TABLE DATA BLOCK GPTT
C
1800 CONTINUE
C
C RECORD 0
C
M1 = 2
M2 = 15
M3 = 16
ASSIGN 1805 TO R
GO TO 8000
1805 CONTINUE
H1(19) = P(1)
H1(20) = P(2)
H1(24) = ZERO
IF ((LC/3)*3 .EQ. 0) GO TO 9905
IVAL = (LC/3)*3
CALL READ (*9903,*1812,F,X,IVAL,0,KF)
GO TO 9905
1812 WD = ((KF-1)/3) + 1
IF (KF .EQ. 0) WD = ((LC-1)/3) + 1
DO 1825 J = 1,WD
LINE = LINE + LS
IF (LINE .LE. NLPP) GO TO 1815
CALL PAGE
WRITE (NO,1)
LINE = LS
1815 IF (P2 .NE. 0) WRITE (NO,1)
IF (X(3*J-1) .EQ. -1) GO TO 1822
WRITE (NO,1821) J,X(3*J-2),RX(3*J-1),X(3*J)
1821 FORMAT (7X,I8,10X,I8,14X,1P,E12.5,19X,I8)
GO TO 1825
1822 WRITE (NO,1823) J,X(3*J-2),X(3*J-1),X(3*J)
1823 FORMAT (7X,I8,10X,I8,14X,6X,I3,22X,I8)
1825 CONTINUE
C
C RECORD 1 AND ALL OTHERS
C
M1 = 17
M2 = 1
M3 = 18
ASSIGN 1835 TO R
GO TO 8000
1835 CONTINUE
DO 1895 RL = 1,J
IF (X(3*RL) .EQ. 0) GO TO 1895
IF ((LC-3*WD) .LT. 4) GO TO 9905
CALL READ (*9903,*9904,F,Y,1,0,KF)
1840 CALL READ (*9903,*1895,F,Z,2,0,KF)
1845 CALL READ (*9903,*9904,F,EID,1,0,KF)
C
C ELEMENT ID EQUALS ZERO INDICATES THE END OF DATA FOR CURRENT TYPE
C
IF ((LC-3*WD) .LT. Z(2)) GO TO 9905
C
C ELEMENT ID LESS THAN ZERO INDICATES NONEXISTENT TEMPERATURE VALUES
C
IF (EID) 1848,1840,1847
1847 IVAL = 3*WD + 1
CALL READ (*9903,*9904,F,X(IVAL),Z(2),0,KF)
1848 A = 3*WD + 1
B = A + 7
IF (B .GE. (A+Z(2))) B = A + Z(2) - 1
LINE = LINE + LS
IF (LINE .LE. NLPP) GO TO 1865
CALL PAGE
WRITE (NO,1850) X(3*RL),Y
1850 FORMAT (9X,I8,11X,I8,11X,I8,13X,I8)
WRITE (NO,1860)
1860 FORMAT (14H0 ELEMENT ID,8X,5H( 1 ),9X,5H( 2 ),9X,5H( 3 ),9X,
1 5H( 4 ),9X,5H( 5 ),9X,5H( 6 ),9X,
2 5H( 7 ),9X,5H( 8 ) )
WRITE (NO,1)
LINE = LS + 3
1865 IF (EID) 1866,1840,1867
1866 WRITE (NO,1870) EID
GO TO 1845
1867 WRITE (NO,1870) EID,(RX(L),L=A,B)
1870 FORMAT (4X,I8,3X,8(2X,1P,E12.5) )
IF (P2 .NE. 0) WRITE (NO,1)
IF (B .EQ. (A+Z(2)-1)) GO TO 1845
A = A + 8
1875 B = A + 7
IF (B .GE. (A+Z(2))) B = A + Z(2) - 1
LINE = LINE + LS
IF (LINE .LE. NLPP) GO TO 1880
CALL PAGE
WRITE (NO,1850) X(3*RL),Y
WRITE (NO,1)
LINE = LS + 3
1880 WRITE (NO,1885) (RX(L),L=A,B)
1885 FORMAT (17X,1P,E12.5,2X,1P,E12.5,2X,1P,E12.5,2X,1P,E12.5,
1 2X,1P,E12.5,2X,1P,E12.5,2X,1P,E12.5,2X,1P,E12.5)
IF (P2 .NE. 0) WRITE (NO,1)
IF (B .EQ. (A+Z(2)-1)) GO TO 1845
A = A + 8
GO TO 1875
1895 CONTINUE
IF (KF .EQ. 0) GO TO 9000
GO TO 9906
C
C PRINT CONTENTS OF TABLE DATA BLOCK GPCT
C
1900 CONTINUE
M1 = 19
M2 = 20
M3 = 21
ASSIGN 1910 TO R
GO TO 8000
1910 CONTINUE
IF (LC .LT. 12) GO TO 9905
J = 0
1920 CALL READ (*1990,*9904,F,PI,1,0,KF)
J = J + 1
WD = 10
LINE = LINE + LS
IF (LINE .LE. NLPP) GO TO 1930
CALL PAGE
WRITE (NO,1)
LINE = LS
1930 IF (P2 .NE. 0) WRITE (NO,1)
CALL READ (*9903,*1980,F,M,1,0,KF)
CALL READ (*9903,*1940,F,X,10,0,KF)
GO TO 1945
1940 WD = KF
1945 WRITE (NO,1950) J,PI,M,(X(L),L=1,WD)
1950 FORMAT (3X,I8,12(2X,I8))
IF (M .LE. 10) GO TO 1920
1960 LINE = LINE + LS
IF (LINE .LE. NLPP) GO TO 1965
CALL PAGE
WRITE (NO,1)
LINE = LS
1965 IF (P2 .NE. 0) WRITE (NO,1)
CALL READ (*9903,*1975,F,X,10,0,KF)
WRITE (NO,1970) (X(L),L=1,WD)
1970 FORMAT (31X,10(2X,I8))
GO TO 1960
1975 WD = KF
WRITE (NO,1970) (X(L),L=1,WD)
GO TO 1920
1980 M = 0
WRITE (NO,1950) PI,M
GO TO 1920
1990 IF (J .EQ. 0) GO TO 9903
GO TO 9000
C
C PRINT CONTENTS OF
C
2000 CONTINUE
GO TO 9000
C
2100 CONTINUE
GO TO 9000
C
2200 CONTINUE
GO TO 9000
C
2300 CONTINUE
GO TO 9000
C
2400 CONTINUE
GO TO 9000
C
2500 CONTINUE
GO TO 9000
C
2600 CONTINUE
GO TO 9000
C
2700 CONTINUE
GO TO 9000
C
2800 CONTINUE
GO TO 9000
C
2900 CONTINUE
GO TO 9000
C
3000 CONTINUE
GO TO 9000
C
3100 CONTINUE
GO TO 9000
C
C
C INTERNAL ROUTINE TO SET HEADINGS AND INITIALIZE LINE COUNTER.
C -------------------------------------------------------------
C
8000 CONTINUE
DO 8010 M = 1,32
H1(M) = HX(M,M1)
H2(M) = HX(M,M2)
H3(M) = HX(M,M3)
8010 CONTINUE
LINE = NLPP
GO TO R, (1110,1205,1255,1310,1501,1555,1710,1805,1835,1910)
C
C
C PRINT TRAILER OF TABLE DATA BLOCK
C ---------------------------------
C
9000 CONTINUE
WRITE (NO,9010) (T(L),L=2,7)
9010 FORMAT (15H0*** TRAILER = ,6I18)
GO TO 9999
C
C
9901 WRITE (NO,9951) UWM,P
9951 FORMAT (A25,' 2094, SUBROUTINE TABFMT, KEYNAME ',2A4,
1 ' NOT IN LIST OF AVAILABLE KEYNAMES.')
GO TO 9993
C
9902 WRITE (NO,9952) UWM
9952 FORMAT (A25,' 2095, SUBROUTINE TABFMT, PURGED INPUT.')
GO TO 9995
C
9903 WRITE (NO,9953) UWM
9953 FORMAT (A25,' 2096, SUBROUTINE TABFMT, EOF ENCOUNTERED.')
GO TO 9995
C
9904 WRITE (NO,9954) UWM
9954 FORMAT (A25,' 2097, SUBROUTINE TABFMT, EOR ENCOUNTERED.')
GO TO 9995
C
9905 WRITE (NO,9955) UWM
9955 FORMAT (A25,' 2098, SUBROUTINE TABFMT, INSUFFICIENT CORE.')
GO TO 9995
C
9906 WRITE (NO,9956) UWM,KF
9956 FORMAT (A25,' 2099, SUBROUTINE TABFMT, KF =',I10)
GO TO 9995
C
9993 WRITE (NO,9994) (NA(1,L),NA(2,L),L=1,LA)
9994 FORMAT ('0*** LIST OF RECOGNIZED KEYNAMES FOLLOWS...', /(20X,2A4))
C
9995 CONTINUE
C
C DO NOT CALL PEXIT SINCE THIS IS AN OUTPUT PROCESSOR.
C
9999 CALL CLOSE (F,1)
RETURN
C
END
|
