-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy patht.f
1564 lines (1564 loc) · 59.3 KB
/
t.f
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
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
program tbm2cos
* *
************************************************************************
* tbm2cos *
************************************************************************
* *
* PURPOSE The utility tbm2cos allows a Cray job to read TBM volumes *
* written by the CDC 7600. 1) It unpacks the original *
* records of a desired file or files from the control-word *
* envelope created by the 7600. 2) It converts those *
* records from 7600 format to Cray format. 3) It writes *
* the resulting records to a user-specified Cray dataset. *
* *
* TBMCONV will not convert all 7600-written volumes to a *
* form which is directly usable on the Cray. Two cases come *
* immediately to mind: 1) If the records written by the *
* 7600 were BUFFERed out and contain mixed-mode data, the *
* user may either have to invoke TBMCONV more than once, *
* with different MODE values, to get several different *
* output datasets which may then be selectively read for the *
* portions properly converted, or to invoke TBMCONV with *
* "MODE=1", so as just to get back the bits written by the *
* 7600, and convert the resulting records using SCONV and/or *
* MCONV. 2) If the records were written on the 7600 using *
* unformatted FORTRAN writes and the parameter "CONV=LG" was *
* not used on the *VOLUME card, then either REFORM or DESEG *
* must be used to get rid of 7600 control words and recreate *
* full-length original data records (which may then need to *
* be operated upon by SCONV and/or MCONV, as well). *
* *
* JCL tbm2cos [-l] [-d] tbm cos *
* *
* tbm Specifies the dataset from which files are to be converted. *
* This dataset must contain a TBM volume written by the 7600 *
* This parameter is required. *
* *
* cos Name of the local dataset to receive the converted files. *
* Separate files in the original volume become separate files *
* on "odn". This dataset is not rewound, either initially or *
* at termination This parameter is required. *
* *
* -l Directory control. If this parameter appears, a directory *
* of the dataset "idn" is produced on stdout. *
* *
* -d Debug control. If set, print the number and size of the *
* records in each file on stdout. *
* *
* Example:
* msread blotto.tbm /MYDIR/subdir/blotto *
* tbm2cos blotto.tbm blotto *
* *
C----------------------------------------------------------------------*
* *
* Notes Binary integers greater than 2 to the 48th power minus 1 *
* in absolute value will not be correctly converted using *
* mode 6 - they will be interpreted as floating-point numbers *
* instead. This is crucial for persons using REFRMT, which *
* assumes that a dataset has been converted with MODE=6. *
* *
* Mode 6 converts 7600 infinites and indefinites into Cray *
* reals which, if used, would cause floating-point overflow. *
* The values used are different depending on whether the 7600 *
* value was a positive or a negative infinite or indefinite, *
* as follows: *
* *
* THE ORIGINAL 7600 VALUE THE RESULTING CRAY VALUE *
* ----------------------- ------------------------ *
* positive infinite 0600004000000000000003B *
* negative infinite 1600004000000000000002B *
* positive indefinite 0600004000000000000005B *
* negative indefinite 1600004000000000000004B *
* *
* where the above Cray numbers are, of course, in octal. *
* *
* DEFINITIONS: *
* *
* LABEL BUFFER - TABLE DESCRIBING THE NAMED FILES ON A VOLUME,*
* GENERATED BY THE CDC 7600 WHEN THE VOLUME WAS CREATED, AND *
* WRITTEN IN THE FIRST TBM BLOCK OF THE VOLUME. *
* *
* TBM BLOCK - 15360 CRAY-1 WORDS (16384 CDC-7600 WORDS). *
* *
* CDC-7600 BLOCK - 2048*BK CDC-7600 WORDS, WHERE "BK" IS AN *
* INTEGER IN THE RANGE 1-80 DEFINING THE BLOCK SIZE USED WHEN *
* THE VOLUME WAS GENERATED ON THE CDC 7600. THE DEFAULT BK *
* IS 8. ALSO CALLED A TLIB BLOCK. *
* *
* CRAY-1 BLOCK - 512 CRAY-1 WORDS. *
* *
* *
* ASSUMPTIONS: *
* *
* THE INPUT DATASET idn IS ASSUMED TO BE AN UNBLOCKED DATASET *
* CONTAINING A TOTAL NUMBER OF WORDS WHICH IS A MULTIPLE OF *
* THE TBM BLOCK SIZE (15360 CRAY-1 WORDS). *
* *
* THE LABEL BUFFER IS ASSUMED TO BE THE 1ST TBM BLOCK OF THE *
* DATASET idn. *
* *
* THE RANGE OF BK IS 1 TO 40. *
* *
* A MODE IS ASSOCIATED WITH EACH RECORD OF A FILE. *
* *
* 0 - DPC *
* 1 - BINARY BIT SERIAL *
* 2 - BCD *
* 3 - ASCII *
* 4 - EBCDIC *
* 5 - BINARY INTEGER *
* 6 - FLOATING-POINT *
* 7 - DPC CARD IMAGE *
* 8 - TRANSPARENT *
* *
* MODE=i Mode override. Specifying a mode causes TBMCONV to treat *
* all records as if they had been written with that mode. *
* The default is to use the value associated with each *
* record as it was written on the 7600. The possible modes *
* and the actions taken by TBMCONV are as follows: *
* *
* MODE ACTION OF TBMCONV *
* ---- -------------------------------------------- *
* *
* 0 Converts DPC characters to ASCII, with the *
* last Cray word zero-filled on the right. *
* *
* 1 No conversion - just transmits the bits of *
* the original record, 64 per word. *
* *
* 2 Intended to cause conversion from BCD to *
* ASCII. Not implemented. *
* *
* 3 No conversion - same effect as 1 - record *
* is assumed to contain ASCII characters. *
* *
* 4 Intended to cause conversion from EBCDIC *
* to ASCII. Not implemented. *
* *
* 5 Converts 60-bit 7600 integers to 64-bit *
* Cray integers. *
* *
* 6 Converts 60-bit 7600 reals to 64-bit Cray *
* reals - if the real has a zero exponent *
* field, it is assumed to be a 60-bit 7600 *
* integer and is converted to a 64-bit Cray *
* integer. *
* *
* 7 Converts DPC cards to ASCII cards - like *
* mode 0, except that COSY characters in each *
* record are expanded into sequences of blanks *
* and the result is forced, by truncation or *
* by blank fill, to exactly eighty characters *
* in length. (A few PLIB volumes were COSYed *
* for the sake of efficiency, and this mode *
* was specifically intended for them, but it *
* may be useful to force the output records *
* to be 80-column card images.) *
* *
* 8 Transparent mode (implies that the original *
* volume was created on the Cray and disposed *
* with "MF=76,DF=TR") - either FN or FS may *
* appear, but not with a list. *
* *
* 9 Transmits the bits of the original record, *
* 60 per word, right-justified, with the four *
* leading bits zeroed. *
* *
* *
* PROGRAM FLOW: *
* *
* 1. TRANSFER AND VERIFY CONTROL CARD PARAMETER VALUES *
* *
* 2. VERIFY LABEL BUFFER INFORMATION AND BUILD NAMED FILE *
* DIRECTORY (BDIR). *
* *
* 3. WRITE NAMED FILE DIRECTORY INFORMATION TO stdout. *
* *
* 4. BUILD THE FILE CONVERSION LIST FROM NAMED FILE *
* DIRECTORY (BCL). *
* *
* 5. CONVERT FILES ACCORDING TO THE FILE CONVERSION LIST AND *
* CONTROL CARD OPTIONS (FCON). *
* *
* 6. EXIT. *
* *
* NOTE: THE ROUTINES OF tbm2cos (AFTER THIS ONE) ARE ARRANGED *
* ALPHABETICALLY, SO THAT THEY MAY BE FOUND EASILY. *
* *
************************************************************************
*
* all variables are integers.
*
implicit integer (a-z)
*
* declare some of the arrays in common. this reduces the overall field
* length required by tbmconv. note that there is a common declaration
* in the routine bbk (which see), as well.
*
common rb1,rb2,dh,dl,bki,cl
*
* the buffers rb1 and rb2 are used by the routine bbk in reading the
* tbm volume.
*
dimension rb1(15360),rb2(16384)
*
* the array fl holds the names (or sequence numbers) of files the user
* wants to convert, taken from the tbmconv control card.
*
dimension fl(3,8)
*
* dh(1) receives the volume name, dh(2) the block size for the volume,
* dh(3) the number of files in the volume, and dh(4) the total number
* of blocks in the volume. this information comes from the volume's
* label buffer.
*
dimension dh(10)
*
equivalence (dh(1),vsn),(dh(2),bk),(dh(3),nedl),(dh(4),nebki)
*
* each entry in dl consists of the sequence number (one word), the name
* (three words), the version number (one word), the obsolete flag (one
* word), the output file sequence number (one word), the starting block
* number (one word), the starting word number (one word), and the total
* number of blocks (one word), of a particular file.
*
dimension dl(10,1000)
*
* bki is indexed by cdc-7600 block number and contains checksums for
* the blocks. currently, this information is not used.
*
dimension bki(5000)
*
* in cl is constructed the list of files to be converted from the
* volume. each six-word entry specifies the name of the file (three
* words), the number of the cdc-7600 block in which it starts (one
* word), the number of the first word of the file in that block (one
* word), and the total number of blocks required to hold the file (one
* word).
*
dimension cl(6,1000)
*
* define the termination message for the user's log file.
*
dimension tcxxx(8)
common/debug/debug
data dbm /1/
character arg*8
*
data (tcxxx(i),i=1,8) /
+ 'tcx01 - ' , 0 , ' files converted ', 0 /
*
* transfer control card parameter values from the jcb into the parameter
* value table pvt.
*
nargs = iargc()
if (nargs .eq. 0) then
call pruse ()
call exit (1)
endif
do 10 i = 1, nargs
nc = getarg (i, arg, 8)
if (arg .eq. "-l") then
dof = 1
ddn = 0
else if (arg(1:2) .eq. '-d') then
do 9 j = 2, 8
if (arg(j:j) .eq. 'd') debug = or (debug, dbm)
dbm = shiftl (dbm, 1)
9 continue
else if (arg(1:1) .eq. '?' .or. arg(1:2) .eq. '-h'
x .or. arg(1:4) .eq. 'help' ) then
call pruse ()
call exit (0)
else if (idn .ne. 5) then
idn = 5
call asnunit (idn, '-O -s u -a' // arg, ier)
if (ier .ne. 0) then
ier = 4
go to 999
endif
else if (odn .ne. 6) then
odn = 6
call asnunit (odn, '-O -a' // arg, ier)
if (ier .ne. 0) then
ier = 4
go to 999
endif
else
print '(" unknown arg ", a8)', arg
call pruse ()
call exit (2)
endif
10 continue
if (odn .ne. 6) then
print
x '("Both the input and output data sets must be specified!")'
call exit (3)
endif
*
* read the first record from the tbm volume (the label buffer).
*
c###############################################################################
fct = 3
c###############################################################################
irp=0
irn=1
call readr(idn,irp,irn,rb1,rb2,ier)
if (ier.ne.0) go to 999
*
* verify label buffer and build directory.
*
lbl=and(rb2(1),o'3777777')
if (lbl.gt.16384) then
ier=1
go to 999
end if
*
call bdir(rb2,dh,dl,bki,ier)
if (ier.ne.0) go to 999
*
bks=bk*2048
*
call dpcasc(vsn,6,vsn)
*
do 101 j=1,nedl
dl(1,j)=j
call dpcasc(dl(2,j),8,dl(2,j))
call dpcasc(dl(3,j),8,dl(3,j))
call dpcasc(dl(4,j),1,dl(4,j))
101 continue
*
* write directory to ddn.
*
call wdir(ddn,dof,dh,dl,ier)
*
* build file conversion table in the array fl.
*
call bcl(dl,nedl,fl,nefl,fct,cl,necl,ier)
if (ier.ne.0) go to 999
*
* convert files and generate output dataset according to file conversion
* table.
*
call fcon(idn,bks,irp,mof,mode,cl,necl,odn,ier)
if (ier.ne.0) go to 999
*
* end of conversion.
*
tcxxx(2)=btd(necl)
call ntb(tcxxx(2))
call remark2(tcxxx)
call close(idn)
*
call exit (0)
*
* process error conditions.
*
999 call error(ier)
call close(idn)
*
if (and (debug, 4) .ne. 0) call abort
call exit (4)
*
end
subroutine bbk(dn,bks,bkn,drp,bkb,ier)
*
************************************************************************
* bbk *
************************************************************************
* *
* purpose: to construct a specified cdc-7600 (tlib) block. *
* *
* entry: dn - name of input dataset (containing tlib volume). *
* bks - cdc-7600 block size. *
* bkn - number of desired block. *
* drp - dataset record position pointer. *
* *
* exit: drp - modified dataset record position pointer. *
* bkb - block constructed. *
* ier - error code. *
* *
************************************************************************
*
* all variables are integers.
*
implicit integer (a-z)
*
* dimension the tlib block buffer.
*
dimension bkb(1)
*
* declare the buffers used to read the tbm volume.
*
common rb1(15360),rb2(16384)
*
* compute the number of the tbm block in which the tlib block begins
* (rn) and the index of its first word (rb2p) in that tbm block.
*
wp=bkn*bks+1
rn=(wp-1)/16384+2
rb2p=mod(wp,16384)
*
* initialize the tlib block buffer pointer.
*
bkbp=1
*
* read up a tbm block.
*
101 call readr(dn,drp,rn,rb1,rb2,ier)
if (ier.ne.0) return
*
* move words from the tbm block buffer to the tlib block buffer.
*
nwm=min0(16385-rb2p,bks-bkbp+1)
call move(rb2,rb2p,bkb,bkbp,nwm)
*
* quit if the tlib block is complete.
*
if (bkbp+nwm.gt.bks) then
ier=0
return
end if
*
* reset the pointers and get the next tbm block.
*
rn=rn+1
rb2p=1
bkbp=bkbp+nwm
go to 101
*
end
subroutine bcl(dl,nedl,fl,nefl,fct,cl,necl,ier)
*
************************************************************************
* bcl *
************************************************************************
* *
* purpose: to build file conversion list. *
* *
* entry: dl - directory list. *
* nedl - number of entries in directory list. *
* fl - file name/file sequence list. *
* nefl - number of entries in file name/file sequence. *
* fct - file conversion type. *
* *
* exit: cl - conversion list. *
* necl - number of entries in conversion list. *
* ier - error code. *
* *
************************************************************************
*
* all variables are integers.
*
implicit integer (a-z)
*
* dimension arrays.
*
dimension dl(10,1),fl(3,1),cl(6,1)
*
* pre-define the error code.
*
ier=0
*
* branch according to the file conversion type.
*
go to (100,200,300,400,500) fct+1
ier=2
return
*
* fct=0 - no file conversion needed.
*
100 necl=0
return
*
* fct=1 - convert files according to fn list.
*
200 do 201 i=1,nefl
call sdlfn(fl(1,i),dl,nedl,sbn,bkbp,tbn,ier)
if (ier.ne.0) return
cl(1,i)=fl(1,i)
cl(2,i)=fl(2,i)
cl(3,i)=fl(3,i)
cl(4,i)=sbn
cl(5,i)=bkbp
cl(6,i)=tbn
201 continue
necl=nefl
return
*
* fct=2 - convert files acording to fs list.
*
300 do 301 i=1,nefl
fsn=dtb(fl(1,i))
if (fsn.le.0.or.fsn.gt.nedl) then
ier=3
return
end if
cl(1,i)=dl(2,fsn)
cl(2,i)=dl(3,fsn)
cl(3,i)=dl(4,fsn)
cl(4,i)=dl(8,fsn)
cl(5,i)=dl(9,fsn)
cl(6,i)=dl(10,fsn)
301 continue
necl=nefl
return
*
* fct=3 - convert all files except obsolete files.
*
400 necl=0
do 401 i=1,nedl
if (dl(6,i).ne.0) go to 401
necl=necl+1
cl(1,necl)=dl(2,i)
cl(2,necl)=dl(3,i)
cl(3,necl)=dl(4,i)
cl(4,necl)=dl(8,i)
cl(5,necl)=dl(9,i)
cl(6,necl)=dl(10,i)
401 continue
return
*
* fct=4 - convert all files.
*
500 do 501 i=1,nedl
cl(1,i)=dl(2,i)
cl(2,i)=dl(3,i)
cl(3,i)=dl(4,i)
cl(4,i)=dl(8,i)
cl(5,i)=dl(9,i)
cl(6,i)=dl(10,i)
501 continue
necl=nedl
return
*
end
subroutine error(ier)
*
************************************************************************
* error *
************************************************************************
* *
* purpose: to write an error message in the user's log file. *
* *
* entry: ier - error code. *
* *
************************************************************************
*
dimension tcexx(8,32)
*
* the error messages are addressed by number. to find the routine
* which caused the error message to be issued, search for a statement
* of the form "ier=n", where "n" is the number of the message that you
* got. (there will only be one such statement in the program.) the
* last five error messages are special, in that they are produced by
* virtue of ier's having been set by the cal routine bdir.
*
data ((tcexx(i,j),i=1,8),j=1,10) /
+ 'tce01 - tbm volume error - label buffer is too long ' , 0 ,
+ 'tce02 - tbmconv logic error - unknown conversion type ' , 0 ,
+ 'tce03 - specified file sequence number is out of range ' , 0 ,
+ 'tce04 - error in fortran-callable assign ' , 0 ,
+ 'tce05 - mode value is outside legal range ' , 0 ,
+ 'tce06 - cray dataset name is longer than 7 characters ' , 0 ,
+ 'tce07 - tlib blocks are too large for buffer in tbmconv ' , 0 ,
+ 'tce08 - record control word from tbm volume is in error ' , 0 ,
+ 'tce09 - data record is too large for buffer in tbmconv ' , 0 ,
+ 'tce10 - error changing dataset mode to unblocked ' , 0 /
*
data ((tcexx(i,j),i=1,8),j=11,20) /
+ 'tce11 - error writing one cray block to output dataset ' , 0 ,
+ 'tce12 - can only request one file in transparent mode ' , 0 ,
+ 'tce13 - unknown record mode - cannot perform conversion ' , 0 ,
+ 'tce14 - bcd-to-ascii conversion is not implemented ' , 0 ,
+ 'tce15 - ebcdic-to-ascii conversion is not implemented ' , 0 ,
+ 'tce16 - error reading record from tbm-volume dataset ' , 0 ,
+ 'tce17 - directory list is empty ' , 0 ,
+ 'tce18 - specified file name is unknown ' , 0 ,
+ 'tce19 - error writing record to output dataset ' , 0 ,
+ 'tce20 - error in fortran-callable save ' , 0 /
*
data ((tcexx(i,j),i=1,8),j=21,30) /
+ 'tce21 - error in fortran-callable release ' , 0 ,
+ 'tce22 - error in fortran-callable access ' , 0 ,
+ 'tce23 - error in fortran-callable delete ' , 0 ,
+ 'tce24 - error writing cray blocks to output dataset ' , 0 ,
+ 'tce25 - fn and fs parameters both specified ' , 0 ,
+ 'tce26 - file name is longer than 17 characters ' , 0 ,
+ 'tce27 - more than 8 file names/numbers are specified ' , 0 ,
+ 'tce28 - label buffer table error ' , 0 ,
+ 'tce29 - file control pointer error ' , 0 ,
+ 'tce30 - block control pointer error ' , 0 /
*
data ((tcexx(i,j),i=1,8),j=31,32) /
+ 'tce31 - directory list table overflow ' , 0 ,
+ 'tce32 - block information table overflow ' , 0 /
*
* put the error message in the user's log.
*
if (ier.ge.1.and.ier.le.32) call remark2(tcexx(1,ier))
*
return
end
subroutine fcon(idn,bks,idrp,mof,mode,cl,necl,odn,ier)
*
************************************************************************
* fcon *
************************************************************************
* *
* purpose: to convert files according to mode and conversion list. *
* *
* entry: idn - input dataset name. *
* bks - size of cdc-7600 (tlib) block. *
* idrp - input dataset record position pointer. *
* mof - mode overwrite flag. *
* mode - mode value. *
* cl - conversion list. *
* necl - number of entries in conversion list. *
* odn - output dataset name. *
* *
* exit: ier - error code. *
* *
************************************************************************
* *
* each record control word in a tlib block has the following format *
* (within a 64-bit cray word). the fields required are unpacked by *
* the routine vrcw. for a complete description of the tlib format, *
* see "the ncar terabit memory system", chapter 8. *
* *
* bits use *
* ----- ------------------------------- *
* 0-3 unused *
* 4 start of record *
* 5 end of data in volume *
* 6 end of file marker *
* 7 unused here *
* 8 label group follows *
* 9-12 unused here *
* 13-18 no. of bits in last word *
* 19-23 mode of data (mof) *
* 24-42 backward record control pointer *
* 43-63 forward record control pointer *
* *
************************************************************************
*
* all variables are integer.
*
implicit integer (a-z)
*
* dimension the conversion list.
*
dimension cl(6,1)
*
* define buffer sizes - to prevent overflow problems, rbcl must be at
* least 1.25 times rb7l.
*
parameter (bkbl=81920,rb7l=40000,rbcl=5*rb7l/4)
*
* define buffers required - bkb receives reconstructed tlib blocks, rb7
* receives user records unpacked from the tlib blocks, rbc receives the
* translation of those records into cray format, and bkbc receives cray
* blocks to be written (only used for transparent mode).
*
dimension bkb(bkbl),rb7(rb7l),rbc(rbcl),bkbc(512)
common/debug/debug
*
* pre-set the error code.
*
ier=0
*
* quit if the conversion list is empty.
*
if (necl.le.0) return
*
* check for a tlib-block-buffer overflow condition.
*
if (bks.gt.bkbl) then
ier=7
return
end if
*
* convert files according to conversion list. variables used below
* include the following:
*
* bkbcp - the index of the next unfilled word in bkbc.
* bkbp - the index of the next record control word in bkb.
* bkn - the number of the next tlib block to be built by bbk (or
* the one which was just built, depending on where you are).
* cbkbn - the number of the tlib block currently in bkb.
* eof - the eof bit from a record control word.
* eoff - a flag used to get around an unadvertised problem with the
* tbm format: normally, the label-buffer pointer to a file
* points to the eof immediately preceding the first data
* record. under certain conditions, it points to the eof
* preceding a label record. in both of these cases, we
* must skip down to the beginning of the data and then
* arrange to stop on the eof following the data.
* fptr - the forward pointer from a record control word.
* lr - the label-record-follows flag from a record control word.
* lwbc - the last-word-bit-count from a record control word.
* rb7p - the index of the next unfilled word in rb7.
* rc - count of records written.
* rcf - record continuation flag - set to 1 to indicate that the
* current user record is continued in the next tlib block.
* rcw - a record control word from the tlib block.
* rmode - the record mode extracted from a record control word.
* trf - transparent flag - set to 1 when processing a volume
* which was disposed from the cray with "mf=76,df=tr".
* wc - count of words written.
*
cbkbn=-1
bkbcp=1
trf=0
*
* loop through the conversion list.
*
do 109 i=1,necl
*
bkn=cl(4,i)
bkbp=cl(5,i)
rc=0
wc=0
rcf=0
rb7p=1
eoff=1
rcnt = 0
lrc = 1
ll = 0
*
* jump if we don't need a new tlib block.
*
101 if (cbkbn.eq.bkn) go to 103
*
* build a new tlib block.
*
102 call bbk(idn,bks,bkn,idrp,bkb,ier)
if (ier.ne.0) return
cbkbn=bkn
*
* jump if the record-continuation flag is set to continue building a
* data record, using words from this tlib block.
*
if (rcf.ne.0) go to 106
*
* unpack and verify the record control word.
*
103 rcw=bkb(bkbp)
call vrcw(rcw,eof,lr,lwbc,rmode,fptr,jer)
if (and (debug, 2) .ne. 0) then
call prrcw (rcw,eof,lr,lwbc,rmode,fptr,jer)
endif
if (jer.ne.0.or.fptr.eq.0) then
ier=8
return
end if
*
* if the record control word represents an end of file: 1) if eoff is
* non-zero, set it to zero and skip to the next record control word.
* 2) if eoff is zero, terminate conversion of this file.
*
if (eof.ne.0) then
if (eoff.eq.0) go to 107
eoff=0
go to 104
end if
*
* if a data record follows the record control word, jump to process it.
* if a label record follows, set the flag eoff non-zero again, so that
* the eof following the label records won't look like an end-of-data
* for the file.
*
if (lr.eq.0) go to 105
eoff=1
*
* skip to the next record control word.
*
104 bkbp=bkbp+fptr
if (bkbp.le.bks) go to 103
bkbp=bkbp-bks
bkn=bkn+1
go to 102
*
* have data record - set eoff to zero.
*
105 eoff=0
*
* check for a data-buffer overflow condition.
*
if (fptr-1.gt.rb7l) then
ier=9
return
end if
*
* add words from the tlib block to the data record being built.
*
106 nwm=min0(bks-bkbp,fptr-rb7p)
call move(bkb,bkbp+1,rb7,rb7p,nwm)
*
* update pointers.
*
bkbp=mod(bkbp+nwm,bks)
rb7p=rb7p+nwm
*
* if the data record is not complete, go back for another block.
*
if (rb7p.lt.fptr) then
rcf=1
bkn=bkn+1
go to 102
end if
*
* the data record is complete - turn off the record-continuation flag
* and reset the pointers so as to pick up the next data record after
* this one is written out.
*
rcf=0
bkbp=bkbp+1
if (bkbp.eq.1) bkn=bkn+1
rb7p=1
*
* set the length and the mode of the output dataset.
*
rl7=fptr-1
*
if (mof.eq.0) mode=rmode
*
* increment the output record count and word count.
*
rc=rc+1
wc=wc+rl7
*
* if we're dealing with a dataset in transparent mode and we haven't
* done so already, change the output dataset to an unblocked dataset.
*
if (mode.eq.8.and.trf.eq.0) then
trf=1
call asnunit (odn, '-I -s u', ier)
if (jer.ne.0) then
ier=10
return
end if
end if
*
* convert the record as implied by the mode.
*
call rcon(mode,rb7,rl7,lwbc,rbc,rlc,ier)
if (ier.ne.0) return
*
* write out the record, using the appropriate routine.
*
if (trf.eq.0) then
call wodn(odn,rbc,rlc,ier)
else
call uwodn(odn,rbc,rlc,bkbc,bkbcp,ier)
end if
if (and (debug , 1) .ne. 0) then
if (ll .ne. rlc) then
if (ll .ne. 0) then
print '(i9, " records sized ", i5)', lrc, ll
endif
ll = rlc
lrc = 1
else
lrc = lrc + 1
endif
rcnt = rcnt + 1
endif
if (ier.ne.0) return
*
* go back for the next data record.
*
go to 101
*
* end of file found - either end-file the output file or, if it is
* being written in transparent mode, zero-fill and dump the last block.
*
107 if (trf.eq.0) then
end file odn
else
if (bkbcp.ne.1) then
do 108 j=bkbcp,512
bkbc(j)=0
108 continue
bkbcp=513
call uwodn(odn,rbc,0,bkbc,bkbcp,ier)
end if
if (necl.gt.1) then
ier=12
return
end if
end if
if (and (debug , 1) .ne. 0) then
if (ll .ne. 0) then
print '(i9, " records sized ", i5)', lrc, ll
endif
ll = rlc
lrc = 1
print '("end file ",i5,i9," records")', i, rcnt
endif
*
109 continue
*
* normal return.
*
return
*
end
subroutine i7tic(a,b,n)
*
************************************************************************
* i7tic *
************************************************************************
* *
* purpose: to convert an array of 60-bit 7600-format integers to *
* an array of 64-bit cray-format integers. *
* *
* entry: a - an array of 7600-format integers, each right-justified *
* in a 64-bit word. *
* n - the number of elements of a to be converted. *
* *
* exit: b - an array of 64-bit cray format integers. *
* *
************************************************************************
*
implicit integer (a-z)
*
* dimension the arrays.
*
dimension a(n),b(n)
*
* loop through the input array.
*
do 101 i=1,n
s=and(shiftr(a(i),59),1)
b(i)=a(i)
if (s.ne.0) b(i)=or(b(i),mask(4))+1
101 continue
*
return
*
end
subroutine move(ia,ias,ib,ibs,nws)
*
************************************************************************
* move *
************************************************************************
* *
* purpose: to move information from one array to another array. *
* *
* entry: ia - array from which information is to be moved. *
* ias - index, in ia, of first word to be moved. *
* ib - array to which information is to be moved. *
* ibs - index, in ib, of destination of first word. *
* nws - number of words to be moved. *
* *
* exit: ib - contains moved information. *
* *
************************************************************************
*
* all variables are integers.
*
implicit integer (a-z)
*
* dimension arrays.
*
dimension ia(1),ib(1)
*
if (nws.gt.0) then
do 101 i=1,nws
ib(ibs+i-1)=ia(ias+i-1)
101 continue
end if
*
return
*
end
subroutine nc7tc(a,b,n)
*
************************************************************************
* nc7tc *
************************************************************************
* *
* purpose: to convert 60-bit 7600-format reals to 64-bit cray-format *
* reals. indefinite, infinite, or unnormalized 7600 reals *
* yield infinite cray reals - the sign bit is set to match *
* that of the 7600 real and the low-order three bits are set *
* to indicate which one or more of the conditions above *
* caused the infinite to be generated. reals with a zero *
* exponent are assumed to be integers and converted as such. *
* *
* entry: a - an array of 7600-format reals, each right-justified in *
* a 64-bit word. *
* n - the number of elements of a to be converted. *
* *
* exit: b - an array of 64-bit cray-format reals. *
* *
************************************************************************
*
implicit integer (a-z)
*
* dimension the arrays.