SUBROUTINE HEXDMP(INPBUF,INBYTES,FUNIT,TITLE) 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/0/ 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 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) .GT. '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