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 IDATA,ICHAR,IFILE,ITRY LOGICAL*1 IDATA,ITABLE,ANS,EBCDIC,NTYN,OCTAL,IASC,IOCT DIMENSION IASC(100),IOCT(306) DIMENSION IDATA(10400),ITABLE(256) 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 SEPERATE FILES.'/) C C TAPE IS REWOUND - TO C 1) MAKE SURE TAPE IS AT BOT (AND TO GET COUNT CORRECT) C 2) INVOLKS DOTAPE TO GET ONLINE C CALL DOTAPE(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.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 DOTAPE(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.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 DOTAPE(1) C C TAPE MARK FOUND??? C 135 IF(ICHAR.NE.0)GOTO 140 C C YES...TAPE MARK HAS BEEN FOUND C 20 FORMAT(' *** TAPE MARK *** FILE : ',I3,' BLOCKS : ',I4) 21 FORMAT('0*** (EOT) FOUND *** DONE *** TAPE IS REWOUND') 22 FORMAT('0**** TAPE ERROR FOUND : FILE=',I3,' , BLOCK=',I4/ + ' **** SKIP TO NEXT BLOCK ****') 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 DOTAPE(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 IDATA,ICHAR,IFILE,NBLOCK DIMENSION IDATA(10400) LOGICAL*1 IDATA,ANS,ANS1 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.NE.'S')GOTO 105 CALL DOTAPE(7) WRITE(5,14) CALL EXIT C C NO ! .. CONTINUE PROGRAM 105 IF(ANS.EQ.'N')RETURN IF(ANS.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 C C READ FILES WHILE SKIPPING 15 FORMAT('0READ FILES WHILE SKIPPING (Y,N)??',$) 16 FORMAT(' ...FILE ',I3,' SKIPPED') 110 WRITE(5,15) READ(5,11)ANS1 C IF(ANS1.EQ.'Y')GOTO 118 IF(ANS1.NE.'N')GOTO 110 DO 115 I=1,NSKIP CALL DOTAPE(4) WRITE(5,16)IFILE IFILE=IFILE+1 115 CONTINUE RETURN C 118 NBLOCK=0 120 CALL DOTAPE(1) C 125 IF(ICHAR.EQ.0)GOTO 130 NBLOCK=NBLOCK+1 GOTO 120 C C FOUND TAPE MARK C 30 FORMAT(' *** 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 118 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 DOTAPE(7) WRITE(5,40) CALL EXIT END SUBROUTINE DOTAPE(IFUN) C C************************************************************ C C SUBROUTINE THAT USES SPECIAL FORTRAN CALLABLE FUNCTIONS TO C READ AND WRITE TO MAG TAPES . THE FUNCTION THAT ARE USED C ARE AS FOLLOWS ; C ISPFNW,IQSET,IGETC C C FOR SUBROUTINE DOTAPE C FOR ARG. IFUN ; 0 = OFFLINE , 4 = SPACE FORWARD C 1 = READ BLOCK , 5 = SPACE BACKWARDS C 2 = WRITE BLOCK , 6 = WRITE / ERG C 3 = WRITE EOF , 7 = REWIND C C REQUIRES THE FOLLOWING COMMON BLOCK C C COMMON IBUFF,IWCNT,IFILE,NBLOCK C C WHERE ; IBUFF = BYTE VARIABLE ARRAY FOR INPUT BUFFER C IWCNT = DATA WORD COUNT C IFILE = FILE COUNT BEING PROCESSED C NBLOCK = BLOCKS READ C C**************************************************************** C COMMON IBUFF,IWCNT,IFILE,NBLOCK DIMENSION IBUFF(5200) LOGICAL*1 ICODE INTEGER*2 ERRADR,ERRBLK(4),DBLK(4) DATA ISET/0/ DATA ERRBLK/0,0,0,0/ DATA DBLK/3RMT0,0,0,0/ C IWCNT=5200 ERRBLK(1)=0 ERRBLK(2)=0 C C IS THIS TH FIRST TIME CALLED ? C IF(ISET.EQ.1)GOTO 100 C C SETUP TAPE CHANNEL C ICHAN=IGETC() IF(ICHAN.LT.0)STOP ' CANNOT GET CHANNEL' LOOK=LOOKUP(ICHAN,DBLK) IF(LOOK.LT.0)STOP 'BAD LOOKUP' ISET=1 C CWHAT FUNCTION ? C 100 ICODE="000 IF(IFUN.EQ.0)ICODE="372 IF(IFUN.EQ.1)ICODE="370 IF(IFUN.EQ.4)ICODE="376 IF(IFUN.EQ.4)IWCNT=0 IF(IFUN.EQ.7)ICODE="373 C IF(ICODE.EQ."000)STOP 'ERROR IN CODE SPECIFICATION' C CDO SPECIAL FUNCTION C ERRADR=IADDR(ERRBLK) C IERR=ISPFNW(ICODE,ICHAN,IWCNT,IBUFF,ERRADR) NBLK=NBLOCK+1 IF(IFUN.EQ.1)WRITE(5,5)IFILE,NBLK,IERR,ERRBLK(1),ERRBLK(2) 5 FORMAT(' ...FILE ',I3,' block #',I4,' ierr=',I1, + ,' errblk(1)='I1' (2)=',I5) C C C RETURN PROPER VALUES FOR NUMBER CHARACTERS READ C IWCNT=0 IF(ERRBLK(1).EQ.6)IWCNT=(5200-ERRBLK(2))*2 C C CHECK IF PARIDY OR OTHER TAPE ERROR C IF(ERRBLK(1).EQ.6 .OR. IERR.NE.2)RETURN C C WRITE LOCATION OF ERROR C NBLOCK=NBLOCK+1 WRITE(5,10)IFILE,NBLOCK,IERR,ERRBLK(1),ERRBLK(2) 10 FORMAT('0**** ERROR IN READING TAPE ****'/ + ' FILE=',I5/ + ' BLOCK=',I4/ + ' IERR=',I1/ + ' ERRBLK(1)=',I1,' (2)=',I5/ + ' **** SKIP TO NEXT FILE ****') IERR=ISPFNW("376,ICHAN,0,IBUFF,ERRADR) C C RESET ICHAR ICHAR=0 NBLOCK=NBLOCK+ERRBLK(2) C IF(IFUN.EQ.4)STOP RETURN END