PROGRAM FDUMP C C This program will present a dump in hexadecimal and ASCII of a disk C file. The first 64 characters are in hex while the last 32 are C in ASCII. C C C MISCELLANEOUS STUFF C CHARACTER FILENAME*32, OUTFILE*32 INTEGER BSTART, BEND, OUNIT, BLKNO, RECSIZE LOGICAL EOF C C BUFFER C COMMON /BUF/ BUFFER(128) INTEGER BUFFER C C DIO STUFF C COMMON /DIO/ ICHAN,IOSB(4),IEOFBLK,IEOFOFF,IRABADR INTEGER*4 ICHAN,IOSBF1,IOSBF2,IEOFBLK,IEOFOFF,IRABADR INTEGER*2 IOSB EQUIVALENCE (IOSB(1),IOSBF1),(IOSB(3),IOSBF2) SAVE /DIO/ C C I/O INTERFACE C INTEGER SYS$QIOW, CHANNEL EXTERNAL IO$_READVBLK, DUOR INTEGER IOB(64) C C GET INFO FROM USER C TYPE *,' FILE DUMP PROGRAM EXECUTING' TYPE *,' Enter input file name' READ (5,8000) FILENAME TYPE *,' Enter output file name (defaults to terminal)' READ (5,8000) OUTFILE 8000 FORMAT (A) OUNIT = 11 IF (OUTFILE(1:4) .EQ. ' ') THEN OUNIT = 6 OUTFILE(1:8) = 'TERMINAL' ENDIF WRITE (6,9999) OUNIT, FILENAME, OUTFILE 9999 FORMAT(' OUNIT=',I2,', FILENAME=',A,', OUTFILE=',A) TYPE *,' Enter start and ending block numbers: S,E' READ (5,8005) BSTART, BEND 8005 FORMAT (BN,I,I) IF (BSTART .GT. BEND) BEND = BSTART IF (BSTART .LT. 1) BSTART = 1 BLKNO = BSTART C C OPEN FILES C OPEN (UNIT=10, FILE=FILENAME, STATUS='OLD', IOSTAT=IOB(4), *USEROPEN=DUOR,SHARED,READONLY) IF (IOB(4) .NE. 0) THEN WRITE (OUNIT, 9030) FILENAME, IOB(4), IOB (5) 9030 FORMAT (' UNABLE TO OPEN FILE: ',A,', ISTAT=',Z4,' IOSB=',Z4) CALL EXIT ENDIF IF (OUNIT .EQ. 11) THEN OPEN (UNIT=11, FILE=OUTFILE, RECL=133, STATUS='NEW') ENDIF C C BIG LOOP C CHANNEL = ICHAN DO UNTIL ((EOF) .OR. BLKNO .GT. BEND) IRET = SYS$QIOW(,%VAL(CHANNEL), IO$_READVBLK, *IOSB,,,%REF(BUFFER), %VAL(512), %VAL(BLKNO),,,) IF (IRET .EQ. 1) THEN RECSIZE = IOSB(2) ELSEIF (IOSB(1) .EQ. '870'X) THEN EOF = .TRUE. EXIT UNTIL ELSE WRITE (OUNIT, 9000) IRET, IOSB(1) 9000 FORMAT (' FDUMP, READ ERROR, ISTAT=',Z4,' IOSB=',Z4) ENDIF C C FORMAT N LINES OF OUTPUT C CALL HEXDMP(BUFFER,512,OUNIT,FILENAME,BLKNO) BLKNO = BLKNO +1 ENDUNTIL C C CLEANUP C CLOSE (10) WRITE (OUNIT, 9005) BEND-BSTART+1 9005 FORMAT ('0FDUMP TERMINATING, ',I4,' BLOCKS PRINTED') IF (OUNIT .NE. 6) THEN WRITE(6,9005) BEND-BSTART+1 CLOSE (OUNIT) ENDIF CALL EXIT C C THAT'S ALL FOLKS C END SUBROUTINE HEXDMP(INPBUF,INBYTES,FUNIT,TITLE,BLKCNT) C C THIS ROUTINE PRINTS CONTENTS OF INPUT BUFFER IN C HEXADECIMAL AND ASCII C INPUTS: C . INPBUF - STARTING ADDRESS OF DUMP C . INBYTES - NUMBER OF BYTES TO DUMP C . FUNIT - OUTPUT UNIT NUMBER C . TITLE - TITLE TO BE PRINTED ON HEADER LINE C OUTPUT: NONE C INTERNAL VARIABLES: C . EDBYTE - END BYTE NUMBER C . IBLANK - A CHARACTER OF BLANK C . INPBUF - 8064 BYTES INPUT BUFFER C . INPBYT - BYTE NUMBER OF INPUT BUFFER C . ITABLE - 0-9 AND A-F IN CHARACTER C . NBLANK - WORD OF BLABKS C . NH1 - 1ST HALF OF A BYTE C . NH2 - 2ND HALF OF A BYTE C . N4BIT - NEXT 4-BIT C . N4BLIN - NUMBER OF 4-BIT CONVERTED TO A PRINT LINE C . OUPBYT - OUPUT BYTE NUMBER C . PCOUNT - BYTE NUMBER FOR PRINT LINE C . PRTBUF - 132 CHARACTERS PRINT BUFFER C . PRTEMP - TEMP PRT BUFFER FOR TRANSLATION C . PRTLIN - BUFFER OF EBCDIC AND ASCII IMAGE C . STATUS - RETURN STATUS FROM LIBRARY TRANS ROUTINE C . STBYTE - START BYTE NUMBER C . TOTN4B - TOTAL NUMBER OF 4-BIT FROM INPUT C C LOGICAL*1 IBLANK LOGICAL*1 ITABLE(16) LOGICAL*1 PRTBUF(132) BYTE INPBUF(8192) CHARACTER*32 PRTEMP INTEGER PRTLIN(31),CHRSET/0/,STATUS,BLKCNT INTEGER STBYTE,EDBYTE,TOTN4B,N4BLIN,OUPBYT INTEGER INPBYT,N4BIT,NHT,NH1,NH2,FUNIT INTEGER*2 PCOUNT CHARACTER*(*) TITLE C EQUIVALENCE (PRTBUF(1),PRTLIN) EQUIVALENCE (PRTEMP,PRTBUF(75)) C DATA ITABLE/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9 *, 1HA,1HB,1HC,1HD,1HE,1HF/ DATA IBLANK/1H / DATA NBLANK/4H / C C WRITE HEADER C CCC BLKCNT = BLKCNT +1 WRITE (FUNIT, 6644) BLKCNT, INBYTES, INBYTES, TITLE 6644 FORMAT ('0 BLOCK NUMBER=',I8,', RECORD SIZE=',I8, *' (',Z4.4,'), TITLE=',A) DO (INITIALIZE.PRINT.BUFFER) TOTN4B = 0 INPBYT = 1 STBYTE = 1 N = INBYTES*2 PCOUNT = 0 C DO WHILE (TOTN4B.LT.N) C C EXTRACT 4 BITS FROM INPUT BUFFER AND CONVERTS TO HEX IN ASCII DO (EXTRACT.4BITS.FROM.INPUT) OUPBYT = OUPBYT + 1 N4BIT = N4BIT + 1 PRTBUF(OUPBYT) = ITABLE(N4BIT) TOTN4B = TOTN4B + 1 N4BLIN = N4BLIN + 1 C C ADDS BLANK AFTER EVERY 4 INPUT 8-BIT BYTE IF (MOD(TOTN4B,8).EQ.0) THEN OUPBYT = OUPBYT + 1 PRTBUF(OUPBYT) = IBLANK IF (MOD(TOTN4B,32) .EQ. 0) THEN OUPBYT = OUPBYT + 1 PRTBUF(OUPBYT) = IBLANK END IF END IF C C IF OUTPUT BUFFER FILLED, PRINT THE LINE AND BLANK PRT BUFFER IF (TOTN4B.EQ.N .OR. N4BLIN.EQ.64) THEN DO (MOVE.BINARY.TO.PRINT.BUFFER) WRITE (FUNIT,200) PCOUNT, PRTLIN 200 FORMAT(1X,Z4.4,2X,31A4) DO (CHECK.DUPLICATES) DO (INITIALIZE.PRINT.BUFFER) PCOUNT = PCOUNT + 32 END IF C END WHILE RETURN C C ---------------------------------------- C PROCEDURE (INITIALIZE.PRINT.BUFFER) DO 500 KK = 1,31 500 PRTLIN(KK) = NBLANK N4BLIN = 0 OUPBYT = 0 STBYTE = INPBYT END PROCEDURE C C ---------------------------------------- C PROCEDURE (EXTRACT.4BITS.FROM.INPUT) IF (MOD(N4BLIN,2).EQ.0) THEN NHT = INPBUF(INPBYT) IF (NHT.LT.0) NHT = 256 + NHT NH1 = NHT/16 NH2 = MOD(NHT,16) N4BIT = NH1 ELSE N4BIT = NH2 INPBYT = INPBYT + 1 END IF END PROCEDURE C C ---------------------------------------- C PROCEDURE (MOVE.BINARY.TO.PRINT.BUFFER) C EDBYTE = STBYTE + N4BLIN/2 - 1 I = 2 PRTBUF(74-2+I) = ' ' PRTBUF(74-1+I) = '*' DO 600 KK = STBYTE,EDBYTE IF (INPBUF(KK) .LT. '20'X .OR. INPBUF(KK) .GE. '7F'X) THEN PRTBUF(74+I) = '.' ELSE PRTBUF(74+I) = INPBUF(KK) ENDIF 600 I = I + 1 PRTBUF(74+I) = '*' C C IF TEXT RECORD AND IN EBCDIC, TRANSLATE TO ASCII C IF (CHRSET.NE.0) THEN STATUS = LIB$TRA_EBC_ASC(PRTEMP, PRTEMP) IF (STATUS.GT.1) WRITE(*,610) 610 FORMAT(' -- ERROR IN TRANSLATION') END IF END PROCEDURE C C CHECK FOR DUPLICATE LINES C PROCEDURE (CHECK.DUPLICATES) IF (INPBYT .LE. INBYTES-33 .AND. INPBYT .GT. 32) THEN ITI = STBYTE ITP = PCOUNT ILC = 0 DO WHILE (ITI .LT. INBYTES-63) DO FOR IL = ITI, ITI+32 IF (INPBUF(IL) .NE. INPBUF(IL+32)) THEN EXIT WHILE ENDIF END FOR ITP = ITP + 32 ITI = ITI + 32 ILC = ILC + 64 END WHILE IF (ITP .GT. PCOUNT + 63) THEN WRITE (FUNIT, 6029) PCOUNT+32, ITP 6029 FORMAT (20X, 'LINES ', Z4.4, ' THRU ', Z4.4, ' SAME AS ABOVE') INPBYT = ITI + 32 PCOUNT = ITP TOTN4B = TOTN4B + ILC ENDIF ENDIF ENDPROCEDURE END