C DUMPMT.FOR COMPLETE PROGRAM FOR C GENERAL PURPOSE MAG. TAPE DUMP C C ******************************************************* C C WRITTEN BY : RON HOEKSEMA C PERSONNEL DEPARTMENT C THE FIRST NATIONAL BANK OF CHICAGO C 1 FIRST NATIONAL PLAZA, 22ND FLOOR C CHICAGO ILLINOIS, 60670 C C DATE : JUNE 10,1982 C C ******************************************************* C C SETUP VARIABLES C COMMON IFILE,IDATA,NBLOCK LOGICAL*1 IDATA,ITABLE,ANS,EBCDIC,NTYN,OCTAL,IASC,IOCT DIMENSION IASC(100),IOCT(306) DIMENSION IDATA(10300),ITABLE(256),ANS(1) C C FUNCTION TO TEST FOR A 'Y' OR 'N' NTYN(ANS)=(ANS.NE.'Y').AND.(ANS.NE.'N') C C WHO ARE WE ??? C WRITE(5,1) 1 FORMAT('1PERSONNEL DEPARTMENT -', + ' GENERAL PURPOSE MAGNETIC TAPE DUMP'// + ' NOTE : TAPE LABELS, HEADERS, AND TRAILERS ARE READ'/ + ' BY THIS PROGRAM AS IF THEY WERE JUST ANOTHER '/ + ' DATA FILE. IN THIS PROGRAM THESE FILES ARE '/ + ' COUNTED AS SEPARATE FILES.'/) C C TAPE IS REWOUND - TO C 1) MAKE SURE TAPE IS AT BOT (AND TO GET COUNT CORRECT) C 2) INVOLKS EXTMT TO GET ONLINE C CALL EXTMT(7) IFILE=1 C C IS THIS AN EBCDIC TAPE ?? C EBCDIC=.FALSE. WRITE(5,2) 100 READ(5,3)ANS IF(NTYN(ANS))GOTO 100 IF(ANS(1).EQ.'N')GOTO 110 2 FORMAT('$IS THIS AN EBCDIC TAPE (Y/N)??') 3 FORMAT(A1) C C TAPE IS EBCDIC ...SETUP TRANSLATION TABLE C C SOME CHARACTERS MUST HAVE SPECIAL HANDLING. C... THE CHARACTER CANNOT BE STORED IN THE EBCDIC C TRANSLATION TABLE WHICH IS STORED IN 'EBCDIC.DAT' IT IS C WRITTEN IN THIS PROGRAM BY STATMENT ; ITABLE(142)=13 C EBCDIC=.TRUE. OPEN (UNIT=2,ACCESS='SEQUENTIAL',NAME='EBCDIC.DAT', + FORM='FORMATTED',TYPE='OLD') READ(2,3)(ITABLE(I),I=1,256) CLOSE(UNIT=2) ITABLE(142)=13 C C READY TO READ A DATA BLOCK - BUT - C ..WHERE ARE WE? C 10 FORMAT('0*** AT THE BEGINNING OF THE TAPE ***') 11 FORMAT('0*** AT THE BEGINNING OF FILE NUMBER ',I4,' ***') 110 IF(IFILE.EQ.1)WRITE(5,10) IF(IFILE.NE.1)WRITE(5,11)IFILE C C PUT IN SKIP FILE CALL OPTION HERE C CALL SKIP C C THIS PROGRAM IS TO TYPE OUT THE FIRST 'NBLOCK' OF DATA C WHICH IS READ ON THE TAPE STARTING AT THE CURRENT POSITION C 12 FORMAT('$ENTER : NUMBER BLOCKS , STARTING BLOCK ') 13 FORMAT(I5) 120 WRITE(5,12) READ(5,*)NBLOCK,NSTART C C SPECIAL THINGS HAPPEN WHEN NBLOCK<=0 C IF NBLOCK=0 ... WILL BE THE SAME AS A SKIP OF THE FILE C IF NBLOCK<0 ... WILL TERMINATE PROGRAM C IF(NBLOCK.GE.0)GOTO 125 15 FORMAT('0*** RUN TERMINATED *** TAPE IS REWOUND ***') CALL EXTMT(7) WRITE(5,15) CALL EXIT C C OCTAL PRINTING ALSO DESIRED C 16 FORMAT('$OCTAL OUTPUT ALSO DESIRED (Y/N) ?') 125 WRITE(5,16) READ(5,3)ANS OCTAL=.FALSE. IF(ANS(1).EQ.'Y')OCTAL=.TRUE. IF(NTYN(ANS))GOTO 125 C C SET FLAGS ... THEN READ DATA BLOCK ISTART=.TRUE. IEOT=0 ITRY=0 NTYPE=0 130 CALL EXTMT(1,10300,IDATA,ICHAR) C C TAPE MARK FOUND??? C IF(ICHAR.NE.0)GOTO 140 C C YES...TAPE MARK HAS BEEN FOUND C 20 FORMAT('0*** TAPE MARK *** FILE : ',I3,' BLOCKS : ',I4) 21 FORMAT('0*** (EOT) FOUND *** DONE *** TAPE IS REWOUND') WRITE(5,20)IFILE,ITRY IFILE=IFILE+1 IEOT=IEOT+1 C C IF SECOND IN A ROW THEN QUIT ..ALSO.. C IF FIRST THING FOUND ON THE TAPE C IF(IEOT.LE.1 .AND. .NOT.ISTART)GOTO 110 WRITE(5,21) CALL EXTMT(7) CALL EXIT C C PREPARE FOR DATA TYPEOUT C 140 IEOT=0 ISTART=.FALSE. ITRY=ITRY+1 IF(NTYPE.GE.NBLOCK .OR. ITRY.LT.NSTART)GOTO 130 NTYPE=NTYPE+1 C C EBCDIC TO ASCII CONVERSION C IF(.NOT.EBCDIC)GOTO 160 DO 150 I=1,ICHAR IDATA(I)=ITABLE(IDATA(I)+129) 150 CONTINUE C C TYPE DATA BLOCK JUST READ C 40 FORMAT('0 FILE NUMBER : ',I4,' BLOCK NUMBER : ',I5 + ,' NUMBER CHAR. READ :'I5) 41 FORMAT(' ASCII ...',100A1) 43 FORMAT('0OCTAL(1).',100A1) 44 FORMAT(' OCTAL(2).',100A1) 45 FORMAT(' OCTAL(3).',100A1) 160 WRITE(5,40)IFILE,ITRY,ICHAR C C HOW MANY LINES ARE TO BE PRINTED? C NLINES=ICHAR/100 IF(ICHAR.GT.NLINES*100)NLINES=NLINES+1 C C C SETUP LOOP TO TYPE NLINES LINES C DO 200 I=1,NLINES MIN=I*100-99 MAX=100*I IF(MAX.GT.ICHAR)MAX=ICHAR C C CONVERT TO OCTAL IF DESIRED IF(.NOT.OCTAL)GOTO 180 ENCODE(300,30,IOCT)(IDATA(J),J=MIN,MAX) 30 FORMAT(100O3) C C WRITE 100 CHAR TO ARRAY FOR PRINTING -AND- C REMOVE NON-PRINTING CHARACTERS FROM LINE C 180 J1=0 DO 190 J=MIN,MAX J1=J1+1 IASC(J1)=IDATA(J) IF(IDATA(J).LT.' ')IASC(J1)=' ' 190 CONTINUE C C HOW MANY CHARACTERS ARE TO BE PRINTED C ON THIS LINE ... THE LAST LINE IN C A BLOCK IS SHORTER THAN 100 CHAR. C LIM=MAX-MIN+1 C C PRINT OUT THE OCTAL VALUES ..IF DESIRED C IF(.NOT.OCTAL)GOTO 195 LIMOCT=LIM*3 WRITE(5,43)(IOCT(J),J=1,LIMOCT,3) WRITE(5,44)(IOCT(J),J=2,LIMOCT,3) WRITE(5,45)(IOCT(J),J=3,LIMOCT,3) C C WRITE ASCII LINE C 195 WRITE(5,41)(IASC(J),J=1,LIM) 200 CONTINUE GOTO 130 END C C SUBROUTINE SKIP C C THIS SUBROUTINE IS CALLED EACH TIME THE TAPE C IS AT THE BEGINNING OF A FILE.. THE OPTION C TO READ THE FILE IS GIVEN -OR- THE OPTION TO SKIP C AS MANY FILES AS DESIRED IS GIVEN. C COMMON IFILE,IDATA,NBLOCK DIMENSION IDATA(10300),ANS(1) LOGICAL*1 IDATA,ANS C C SKIP DESIRED ?? C 10 FORMAT('$SKIP ANY FILES OR STOP (Y/N/S) ? ') 11 FORMAT(A1) 12 FORMAT('$HOW MANY ? ') 13 FORMAT(I3) 14 FORMAT('0*** STOP PROGRAM *** TAPE HAS BEEN REWOUND ***') 100 WRITE(5,10) READ(5,11)ANS C C STOP PROGRAM ?? IF(ANS(1).NE.'S')GOTO 105 CALL EXTMT(7) WRITE(5,14) CALL EXIT C C NO ! .. CONTINUE PROGRAM 105 IF(ANS(1).EQ.'N')RETURN IF(ANS(1).NE.'Y')GOTO 100 C C HOW MANY ..ZERO OR LESS ALSO MEANS NONE C WRITE(5,12) READ(5,13)NSKIP IF(NSKIP.GT.0)GOTO 110 C C NONE SPECIFIED C 20 FORMAT(' NONE SPECIFIED ... NONE SKIPED!') WRITE(5,20) RETURN C C LOOP UNTIL TAPE MARK IS FOUND C 110 NBLOCK=0 120 CALL EXTMT(1,10300,IDATA,ICHAR) IF(ICHAR.EQ.0)GOTO 130 NBLOCK=NBLOCK+1 GOTO 120 C C FOUND TAPE MARK C 30 FORMAT('0*** TAPE MARK *** FILE : ',I3,' BLOCKS : ',I4) 130 WRITE(5,30)IFILE,NBLOCK NSKIP=NSKIP-1 IFILE=IFILE+1 C C TIME TO RETURN ? -OR- CONTINUE SKIPPING C IF(NSKIP.GT.0)GOTO 140 35 FORMAT('0*** AT THE BEGINNING OF FILE NUMBER ',I4,' ***') WRITE(5,35)IFILE RETURN C 140 IF(NBLOCK.NE.0)GOTO 110 C C FOUND 2 TAPE MARKS IN A ROW -OR- C RIGHT AT THE START C 40 FORMAT('0***END OF TAPE FOUND DURING FILE SKIPPING***' + /'*** TAPE HAS BEEN REWOUND ***') CALL EXTMT(7) WRITE(5,40) CALL EXIT END