PROGRAM TAPE2DISK C C TAPE2DISK PROGRAM C C This program will read unlabeled magtapes containing fixed or variable C length records. Tape files are deblocked, and written to disk. C Optionally: C Trailing spaces and card sequence fields can be removed. C EBCDIC & BCD codes can be translated to ASCII. C C ********************************************************** PARAMETER BUFSIZE=32767 !INPUT WORKING BUFFER SIZE C PARAMETER EOF='879'X PARAMETER NOLOGNAM='908'X !RETURN CODE PARAMETER NOPRIV = '24'X !RETURN CODE PARAMETER IO$_READLBLK = '21'X !READ LOGICAL BLOCK CODE FOR QIO PARAMETER IO$_REWIND = '24'X !REWIND FUNCTION CODE FOR QIO C INTEGER*2 CHANNEL,ENDFLAG,IOSB(4) INTEGER*4 SYS$ASSIGN,SYS$QIOW,RETCODE,LRECL CHARACTER OUTFILE*13,BUFFER*(BUFSIZE) CHARACTER TRANS*1,STRIP*1,CODE*1,CR*1,RFORMAT*1,RSPAN*1,LF*1 CHARACTER NULL*1 CHARACTER ANSWER*1 INTEGER MINSIZE,MAXSIZE DATA CR /'0D'X/ !CARRIAGE RETURN CHARACTER DATA LF /'0A'X/ !LINE FEED CHARACTER DATA NULL /'00'X/ !NULL BYTE 1000 FORMAT (A) 2000 FORMAT (I4) C *************************************************************** C SETUP C WRITE(6,*)' Tape input is from logical name "TAPE" or "TAPEUNIT"' RETCODE=SYS$ASSIGN('TAPE',CHANNEL,,) IF(RETCODE.NE.1)THEN RETCODE=SYS$DASSGN(CHANNEL) RETCODE=SYS$ASSIGN('TAPEUNIT',CHANNEL,,) IF(RETCODE.NE.1)GO TO 9000 END IF NUMFILE=1 ENDFLAG=0 C C Rewind the tape C RETCODE = SYS$QIOW(,%VAL(CHANNEL),%VAL(IO$_REWIND),IOSB,,,,,,,,) IF (RETCODE .NE. 1) GO TO 9000 C C ************************************************************* C ************************************************************* C Get parameters for the TAPE2DISK C 4 WRITE(6,*)' ***** Enter tape-copy processing parameters *****' C !SET DEFAULT VALUES TRANS = 'N' !NO TRANSLATE RFORMAT = 'F' !FIXED FORMAT RECORDS LRECL = 80 !80 CHAR LOGICAL RECORD LENGTH STRIP = 'N' !NO STRIP TRAILING BLANKS RSPAN = 'N' !DO NOT SPAN BLOCKS C 5 WRITE (6,6) 6 FORMAT ( ' Please enter tape format type (1-4)',/, 1 '$ or enter 0 to see a list of format types: ') READ (5,2000) MODE IF (MODE .EQ. 0) THEN WRITE(6,1100) 1100 FORMAT(' TAPE2DISK will process the following magtape formats'/ 2 ' 1 = fixed length data records'/ 3 ' - 1 or more records / block'/ 4 ' 2 = variable length data records' / 5 ' - delimited by '/ 6 ' - 1 or more records / block'/ 6 ' - (this is PDP-10 change program format)'/ 7 ' 3 = fixed length records'/ 8 ' - only one record / block '/ 9 ' - ignore all data after 1st record in block'/ & ' 4 = variable length data records' / & ' - 1 record per block') GO TO 5 ENDIF GO TO (10,20,30,40) MODE !CONTINUE TYPE SPECIFIC SETUP C WRITE(6,*) ' File type must be a value from 1-4.' !ERROR GO TO 5 C C C******* FIXED LENGTH DATA RECORDS 10 RFORMAT = 'F' RSPAN = 'Y' WRITE(6,11) 11 FORMAT('$Enter input logical record length (NOT BLOCKSIZE) : ') READ(5,2000)LRECL IF(LRECL.GT.BUFSIZE)THEN WRITE(6,*)' Record size too large (MAX=32767 bytes)' GO TO 10 END IF IF(LRECL.LE.0)THEN LRECL=80 WRITE(6,*) ' 80 char record assumed' END IF IF ((LRECL.EQ.80).OR.(LRECL.EQ.96)) THEN WRITE (6,*)' These files are the size of card images...' WRITE (6,15) LRECL 15 FORMAT( 1 '$Do you want to strip off columns 73-',I2, 1 ' and strip trailing blanks (Y/N)? ') READ (5,1000) STRIP IF (STRIP .NE. 'Y' ) STRIP = 'N' ENDIF GO TO 80 C C******* VARIABLE LENGTH RECORDS 20 RFORMAT = 'V' RSPAN = 'Y' GO TO 80 C C******** FIXED LENGTH, 1 RECORD PER BLOCK 30 RFORMAT = 'F' RSPAN = 'N' GO TO 80 C *************MODE 4 VARAIBLE LENGTH************** 40 RSPAN = 'F' RFORMAT = 'V' GO TO 80 C ****************************** C 80 WRITE (6,1200) 1200 FORMAT(' Do you want to translate input to ASCII ', 2 $,'from EBCDIC or BCD (Y/N) ? ') READ (5,1000) TRANS IF (TRANS .EQ. 'Y' ) THEN IF (MODE .EQ. 2) THEN WRITE(6,*)' Format 2 requires ASCII input data' GO TO 5 ENDIF CALL TRANSETUP !SETUP TRANSLATION PARAMETERS ENDIF C ************************************************************* C ************************************************************* C PREPARE FOR OUTPUT C 100 WRITE(6,101) 101 FORMAT('$ENTER "FILENAME.TYP" or "STOP" or "SKIP" or "NEW": ') READ(5,1000)OUTFILE C C TEST TO SEE IF WE'RE DONE IF (OUTFILE .EQ. 'STOP') THEN STOP 'User requested exit' ENDIF MINSIZE=999999 MAXSIZE=0 C IF (OUTFILE .EQ. 'NEW') GO TO 4 C C C SHOULD WE SKIP OVER SOME FILES? IF (OUTFILE .EQ. 'SKIP') THEN WRITE(6,102) 102 FORMAT('$How many files do you want to skip ? : ') READ (5,2000) NUMFILES DO 120 I=1,NUMFILES 110 RETCODE=SYS$QIOW(,%VAL(CHANNEL),%VAL(IO$_READLBLK),IOSB,,, 2 %REF(BUFFER(1:1)),%VAL(BUFSIZE),,,,) C ******* CHECK FOR EOF OR ZERO LENGTH RECORD (I.E. FUNNY EOF) IF((IOSB(1).EQ.EOF).OR.(IOSB(2).EQ.0)) THEN C LAST READ WAS EOF ... TEST FOR EOT (= 2 EOF'S) IF (ENDFLAG .NE. 0) THEN WRITE(6,3500)NUMFILE 3500 FORMAT(' Empty file skipped...file number',I4) NUMFILE = NUMFILE + 1 ENDFLAG=1 GO TO 120 ELSE ENDFLAG = 1 !ONE EOF SEEN NUMFILE = NUMFILE + 1 GO TO 120 !COUNT ONE FILE ENDIF ENDIF ENDFLAG = 0 !NOT FILE GO TO 110 !CONTINUE READING TO FILE 120 CONTINUE GO TO 100 ENDIF C ******************************************************** C PREPARE THE OUTPUT FILE AND CONTROL VARIABLES C IBLKSIZE = 0 !# OF BYTES ACTUALLY READ NUMRECS=0 !# OF RECORDS ISTART = 1 !BEGINNING OF INPUT BUFFER IREMAIN = 0 !# OF BYTES LEFT FROM PREVIOUS BLOCK C OPEN(UNIT=1,NAME=OUTFILE,CARRIAGECONTROL='LIST', & STATUS='NEW',RECORDSIZE=BUFSIZE) C C ********************************************************* C ********************************************************* C GET AN INPUT RECORD C 200 RETCODE=SYS$QIOW(,%VAL(CHANNEL),%VAL(IO$_READLBLK),IOSB,,, 1 %REF(BUFFER(ISTART:ISTART)),%VAL(BUFSIZE),,,,) IF(RETCODE.NE.1)GO TO 9000 !CHECK FOR ERROR RETURN IBLKSIZE = IOSB(2) !SIZE OF ACTUAL INPUT DATA PHYSICAL RECORD IF((IBLKSIZE+IREMAIN) .GT. BUFSIZE)THEN WRITE(6,3600) 3600 FORMAT(' Input record too large',/, & ' size is',I6,' bytes, buffer size is ',I6, & ' bytes') STOP ENDIF C C CHECK FOR EOF OR ZERO LENGTH BLOCK IF((IOSB(1).EQ.EOF).OR.(IOSB(2).EQ.0)) THEN C C TEST FOR TAPE IF(ENDFLAG.NE.0)THEN WRITE(6,3601) 3601 FORMAT(' Empty file encountered(END OF TAPE)',/, & ' Do you want to continue? (Y/N)') READ(5,1000)ANSWER IF(ANSWER.EQ.'Y')THEN NUMFILE=NUMFILE+1 ENDFLAG=1 CLOSE(UNIT=1) GO TO 100 ENDIF STOP 'END OF TAPE' ELSE !END OF CURRENT INPUT FILE ENDFLAG=1 CLOSE(UNIT=1) C REPORT SUMMARY STATISTICS WRITE(6,4000)NUMFILE,NUMRECS WRITE(6,4001)MINSIZE,MAXSIZE 4001 FORMAT(' MINIMUM BLOCKSIZE=',I6, & ' MAXIMUM BLOCKSIZE=',I6) 4000 FORMAT(' End of file # ',I8,': ',I8,' records written') NUMFILE = NUMFILE + 1 GO TO 100 !GET READY FOR NEXT INPUT FILE END IF END IF C C DE-BLOCK AND WRITE OUTPUT RECORDS MINSIZE=MIN(MINSIZE,IBLKSIZE) MAXSIZE=MAX(MAXSIZE,IBLKSIZE) ENDFLAG = 0 !CLEAR EOF. THERE IS STILL DATA TO PROCESS IF ((IBLKSIZE.LT.LRECL) .AND. (RFORMAT.EQ.'F')) THEN WRITE(6,4100)IBLKSIZE,LRECL 4100 FORMAT(' Rec has ',I4,' bytes...ignore it', & ' LOGICAL RECORD LENGTH=',I6) GO TO 200 END IF NUMBYTES = IBLKSIZE + IREMAIN !TOTAL # OF CHARS IN BUFFER C C DISPATCH TO DEBLOCK AND WRITE OUTPUT RECORD GO TO (600,700,600,800) MODE C C *************************************************************** C *************************************************************** C FIXED LENGTH RECORD PROCESSING 600 IREMAIN = NUMBYTES !# OF INPUT CHARS REMAINING TO PROCESS DO 650 I=1,NUMBYTES,LRECL C CHECK FOR BLOCK SPANNING IF (IREMAIN .LT. LRECL) THEN IF (IREMAIN .GT. 0) THEN BUFFER(1:IREMAIN) = BUFFER((NUMBYTES-IREMAIN+1):NUMBYTES) ENDIF ISTART = IREMAIN+1 !RESET BEGINNING OF BUFFER POINTER GO TO 200 ENDIF C C END OF LOGICAL RECORD PROCESSING C C PERFORM CODE TRANSLATION C IF (TRANS .EQ. 'Y') CALL XLATE(LRECL,BUFFER(I:I)) !TRANSLATE 1 REC C C K = I+LRECL-1 !END OF OUTPUT RECORD IF (STRIP .EQ. 'Y') THEN !FIND LAST NON-BLANK IN RECORD DO 610 K = I+71 , I , -1 !IGNORE COL 73 ->END OF RECORD 610 IF (BUFFER(K:K) .NE. ' ') GO TO 620 !FOUND IT ENDIF C C 620 WRITE(1,1000)BUFFER(I:K) !PUT OUT ONE RECORD NUMRECS=NUMRECS+1 C C REPORT PROGRESS EVERY 100 RECORDS PROCESSED IF (MOD(NUMRECS,100) .EQ. 0) WRITE(6,4200) NUMRECS 4200 FORMAT(' RECORD: ',I8) IREMAIN = NUMBYTES-(I+LRECL-1) !UPDATE REMAINING CHAR COUNT IF (MODE .EQ. 3) GO TO 200 !SINGLE RECORD PER BLOCK C 650 CONTINUE !PROCESS NEXT RECORD GO TO 200 C C ************************************************************** C ************************************************************** C VARIABLE LENGTH RECORD PROCESSING (FORMAT 2) C 700 L = 1 !BEGINNING OF RECORD POINTER K = 1 !END OF RECORD POINTER C C******* SEARCH FOR CARRIAGE RETURN/LINE FEED DELIMITER 710 IF (BUFFER(K:K) .EQ. CR) GO TO 720 IF (BUFFER(K:K) .EQ. LF) L = L+1 !SKIP OVER LINE FEEDS IF (BUFFER(K:K) .EQ. NULL) L=L+1 !SKIP NULL BYTES. C !NULLS ARE AT THE END OF BLOCKS C !WRITTEN BY EARLY DEC-10 TAPES. C !THESE DRIVES ONLY WRITE EVEN C !NUMBER OF PDP-10 WORDS. K = K+1 !DIDN'T FIND , CONTINUE THE SCAN IF (K .LE. NUMBYTES) GO TO 710 !TEST FOR END OF BLOCK C END OF BLOCK PROCESSING C C CHECK FOR BLOCK SPANNING IREMAIN = K - L + 1 IF (IREMAIN .GT. 0) THEN BUFFER(1:IREMAIN) = BUFFER((NUMBYTES-IREMAIN+1):NUMBYTES) ENDIF ISTART = IREMAIN+1 !RESET BEGINNING OF BUFFER POINTER GO TO 200 C C END OF VARIABLE LENGTH RECORD PROCESSING C 720 WRITE (1,1000)BUFFER(L:K-1) !WRITE REC- LESS CR,LF&NULLS NUMRECS = NUMRECS+1 !BUMP OUTPUT RECORD COUNT K = K+1 !BUMP POINTER PAST THE CHARACTER L = K !PREPARE TO SCAN FOR NEXT RECORD IF (MOD(NUMRECS,100).EQ.0) WRITE(6,4200)NUMRECS GO TO 710 C C *************************************************** C ******************VARIABLE LENGTH MODE 4********** C CHECK FOR TRANSLATION 800 IF(TRANS .EQ. 'Y')THEN CALL LIB$TRA_EBC_ASC(BUFFER(1:IBLKSIZE), & BUFFER(1:IBLKSIZE)) END IF WRITE(1,1000)BUFFER(1:IBLKSIZE) NUMRECS=NUMRECS+1 C C REPORT PROGRESS EVERY 100 RECORDS PROCESSED IF (MOD(NUMRECS,100) .EQ. 0) WRITE(6,4200) NUMRECS GO TO 200 C ************************************************************** C ERROR PROCESSING 9000 IF (RETCODE .EQ. NOLOGNAM) THEN WRITE(6,*)' ********************************' WRITE(6,*)' Logical name "TAPE" not assigned' WRITE(6,*)' ********************************' ENDIF IF (RETCODE .EQ. NOPRIV) THEN WRITE(6,*)' ***********************************' WRITE(6,*)' "TAPE" must be MOUNTED/FOREIGN' WRITE(6,*)' ***********************************' ENDIF WRITE(6,3000)RETCODE 3000 FORMAT(' ******************************************'/ 2 ' SYSTEM CALL RETURN CODE = ',Z8,' HEX'/ 3 ' ******************************************') END C C TRANSLATION SETUP ROUTINE C SUBROUTINE TRANSETUP C C PARAMETER MAX_PAT = 5 !MAX # OF PATTERNS ACCEPTED PARAMETER MAX_FIELD = 10 !MAX # OF FIELDS PER PATTERN C C COMMON /NUMDATA/ 1 ICODE, !EBCDIC VS BCD CODE TRANSLATION 1 IMODE, !TYPE OF TRANSLATION PROCESS 1 NUM_PATTERNS, !# OF PATTERNS TO CHOOSE FROM 1 LEN_SELECT, !LENGTH OF PATTERN SELECTION FIELD 1 LOC_SELECT, !BYTE # OF FIRST BYTE OF SEL. FIELD 1 IFIELD(MAX_PAT,MAX_FIELD,2) !FIELD SPECIFIERS C LEAST SIG DIMENSION: LENGTH,START_LOC C COMMON /CHRDATA/ 1 PAT_SELECT !ARRAY OF PATTERN SELECTION FIELDS C CHARACTER*20 PAT_SELECT(MAX_PAT) C 10 WRITE(6,11) 11 FORMAT('$Select EBCDIC or BCD (E/B): ') READ (5,1000) CODE 1000 FORMAT (A) IF (CODE .EQ. 'E') THEN ICODE = 1 GO TO 15 ENDIF IF (CODE .EQ. 'B') THEN ICODE = 2 GO TO 15 ENDIF GO TO 10 !ERROR ON SPECIFICATION C C 15 WRITE (6,*) ' Select translation mode (1-3)' WRITE (6,16) 16 FORMAT('$ or enter 0 to see list of modes: ') C 20 READ (5,2000) IMODE 2000 FORMAT (I4) GO TO (100,200,300) IMODE C C TYPE EXPLAINATORY MESSAGE WRITE (6,3000) 3000 FORMAT (' 1 = Translate entire record as one field'/ 1 ' 2 = Translate a fixed pattern of fields '/ 1 ' in each record'/ 1 ' 3 = Use the contents of one A/N input field'/ 1 ' to select a pattern of fields to translate') C GO TO 15 C C C SINGLE FIELD TRANSLATE 100 RETURN !NO FURTHER SETUP REQUIRED C C C SINGLE PATTERN OF FIELDS SETUP 200 NUM_PATTERNS = 1 GO TO 320 C C C MULTIPLE PATTERN OF FIELDS SETUP 300 WRITE(6,301) 301 FORMAT('$How many patterns will be specified? ') READ(5,2000) NUM_PATTERNS IF((NUM_PATTERNS .LE. MAX_PAT).AND.(NUM_PATTERNS .GE. 2)) GO TO 310 C ERROR IN NUM OF PATTERNS SELECTED WRITE(6,*)' WRONG! Enter value from 2-5' GO TO 300 C C 310 WRITE(6,311) 311 FORMAT('$Enter "START_BYTE_#,LENGTH" of field used to ', 1 'select a pattern: ') READ (5,315) LOC_SELECT,LEN_SELECT 315 FORMAT(2I4) C C C GET PATTERN SPECIFICATIONS 320 WRITE(6,325) MAX_FIELD 325 FORMAT(' Specify a maximum of ',I3,' fields per pattern'/ 1 ' end specification with 0 input') C C 330 DO 400 I = 1,NUM_PATTERNS IF (NUM_PATTERNS .GT. 1) THEN WRITE (6,340) I 340 FORMAT('$Enter contents of A/N field which selects' 1 ' pattern ',I2,': ') READ(5,1000) PAT_SELECT(I) ENDIF WRITE (6,350) I 350 FORMAT(' Enter "START_BYTE_#,LENGTH' 1 $,' of each field to be translated in pattern ',I2,': ') C DO 390 J = 1,MAX_FIELD WRITE (6,360) J 360 FORMAT('$FIELD:',I2,' START,LEN: ') READ (5,370) IFIELD(I,J,2),IFIELD(I,J,1) 370 FORMAT(2I4) IF (IFIELD(I,J,1) .EQ. 0) GO TO 400 390 CONTINUE 400 CONTINUE RETURN C C C********************************************************************** END SUBROUTINE XLATE(IRECLEN,BUFFER) C C PARAMETER MAX_PAT = 5 !MAX # OF PATTERNS ACCEPTED PARAMETER MAX_FIELD = 10 !MAX # OF FIELDS PER PATTERN C COMMON /NUMDATA/ 1 ICODE, !EBCDIC VS BCD CODE TRANSLATION 1 IMODE, !TYPE OF TRANSLATION PROCESS 1 NUM_PATTERNS, !# OF PATTERNS TO CHOOSE FROM 1 LEN_SELECT, !LENGTH OF PATTERN SELECTION FIELD 1 LOC_SELECT, !BYTE # OF FIRST BYTE OF SEL. FIELD 1 IFIELD(MAX_PAT,MAX_FIELD,2) !FIELD SPECIFIERS C LEAST SIG DIMENSION: LENGTH,START_LOC C COMMON /CHRDATA/ 1 PAT_SELECT !ARRAY OF PATTERN SELECTION FIELDS C CHARACTER*20 PAT_SELECT(MAX_PAT) CHARACTER BUFFER*(*),SELECT*20 C GO TO (600,700,800) IMODE C C C SINGLE FIELD TRANSLATION 600 CALL TRANSL (IRECLEN,BUFFER(1:1),ICODE) RETURN C C C SINGLE PATTERN TRANSLATION 700 J = 1 !SELECT PATTERN 1 GO TO 820 C C C CHOOSE PATTERN BASED ON CONTENTS OF SELECTION FIELD C C EXTRACT SELECTION FIELD FROM INPUT AND CONVERT IT TO ASCII 800 SELECT(1:LEN_SELECT)=BUFFER(LOC_SELECT:LOC_SELECT+LEN_SELECT) CALL TRANSL (LEN_SELECT,SELECT(1:1),ICODE) C C SELECT PATTERN TO USE BASED ON CONTENTS OF STRING "SELECT" DO 810 J = 1,NUM_PATTERNS IF (PAT_SELECT(J) .EQ. SELECT(1:LEN_SELECT)) GO TO 820 !FOUND 810 CONTINUE C C C 820 DO 850 I = 1,MAX_FIELD IF (IFIELD(J,I,1) .EQ. 0) RETURN !DONE 850 CALL TRANSL (IFIELD(J,I,1), 1 BUFFER(IFIELD(J,I,2):IFIELD(J,I,2)), 1 ICODE) RETURN END