C TAPER.FOR MAIN PROGRAM FOR TAPE READER C FOR INFORMATION, READ TAPER.HLP C C ************************************************************************ C C WRITTEN BY: ROGER MATUS, DOUGLAS BOHRER C PERSONNEL DEPARTMENT, THE FIRST NATIONAL BANK OF CHICAGO C 1 FIRST NATIONAL PLAZA, 22ND FLOOR C CHICAGO, ILLINOIS 60670 C C DATE: 11-JUN-80 C C ************************************************************************ C C C DIMENSION, INITIALIZE C COMMON IFILE,IDATA LOGICAL*1 IDATA,ITABLE,FILNAM,FMT,ANS,EBCDIC,NTYN,A DIMENSION IDATA(10200),ITABLE(256),FILNAM(20),FMT(8),ANS(1),A(1) EBCDIC=.FALSE. C C A FEW HANDY FORMATS (NUMBERED 1-9) C 1 FORMAT (' ') 2 FORMAT (A1) 3 FORMAT (' --------------------------------------------------', 1'----------------------') 4 FORMAT (I5) 5 FORMAT ('0AT BEGINNING OF FILE',I6,'.') C C ONE NIFTY LITTLE FUNCTION C NTYN(A)=(A.NE.'Y').AND.(A.NE.'N') C C LET'S TELL THE USER WHO WE ARE C WRITE (5,10) 10 FORMAT ('1',20X,'PERSONNEL DEPARTMENT MAGNETIC TAPE READER') WRITE (5,1) C C REWIND THE TAPE (IT'S A FEAURE) C C THIS REWIND IS IMPORTANT BECAUSE IT (1) MAKES SURE THAT WE ARE C AT THE BOT (AND, THEREFORE, THE COUNTS ARE CORRECT), AND C (2) INVOKES EXTMT TO SEE THAT WE ARE ON LINE, ETC. BEFORE ANY C SERIOUS WORK IS DONE. C CALL EXTMT(7) IFILE=1 C C IS THIS AN EBCDIC TAPE? C 11 FORMAT ('$IS THIS AN EBCDIC TAPE (Y/N)? ') 110 WRITE (5,11) READ (5,2) ANS IF (NTYN(ANS)) GO TO 110 IF (ANS(1).EQ.'N') GO TO 130 C C IT IS AN EBCDIC TAPE. LET'S SET UP THE TRANSLATION TABLE. C C NOTE: THE CHARACTER CANNOT BE WRITTEN ONTO FILE EBCDIC.DAT C BECAUSE DEC RECOGNIZES THIS AS A RECORD TERMINATOR. THIS C CHARACTER IS INSERTED BY THE STATEMENT: ITABLE(142)=13. C NOTE: THE CHARACTER (DECIMAL 33, HEX 3F) IS TRANSLATED AS C AS A SPACE. DEC RECOGNIZES THIS CHARACTER Z C AS THE LOGICAL END OF FILE AND MUST NOT BE WRITTEN TO DISC. C EBCDIC=.TRUE. OPEN (UNIT=2,ACCESS='SEQUENTIAL',NAME='EBCDIC.DAT', 1FORM='FORMATTED',TYPE='OLD') READ (2,2) (ITABLE(I),I=1,256) CLOSE (UNIT=2) ITABLE(142)=13 C C WHERE ARE WE? TELL THE USER (MAYBE DRIVE IS FAR AWAY) C 12 FORMAT ('0AT BEGINNING OF TAPE (BOT).') 130 IF (IFILE.EQ.1) WRITE (5,12) IF (IFILE.NE.1) WRITE (5,5) IFILE C C SHALL WE SKIP ANY FILES? C 14 FORMAT ('$SKIP ANY FILES (Y/N)? ') 140 WRITE (5,14) READ (5,2) ANS IF (NTYN(ANS)) GO TO 140 IF (ANS(1).EQ.'N') GO TO 210 C C HOW MANY FILES SHOULD WE SKIP? (.LE.0 MEANS NONE) 15 FORMAT ('$HOW MANY? ') WRITE (5,15) READ (5,4) NFILES C NOTE: PROGRAM DOES NOT CHECK FOR NON-NUMERICS. IF (NFILES.LE.0) GO TO 210 C C CALL ROUTINE TO SKIP FILES C C NOTE: IF LOGICAL END OF TAPE IS FOUND, EXECUTION WILL TERMINATE IN C SUBROUTINE WITHOUT RETURN. CALL SKIP(NFILES) C C C WE'RE READY TO READ SOME DATA NOW. C FIRST, SET-UP A FEW FLAGS. C 210 ISTART=.TRUE. ITRY=0 IF (IFILE.EQ.1) WRITE (5,12) IF (IFILE.NE.1) WRITE (5,5) IFILE C C C READ A BLOCK OF DATA C 220 DO 100 I=1,72 IDATA(I)=0 100 CONTINUE CALL EXTMT(1,10200,IDATA,ICHAR) C C DID WE FIND A MARK? C IF (ICHAR.NE.0) GO TO 230 C C YES, A MARK. C 16 FORMAT (' MARK FOUND.') WRITE (5,16) IFILE=IFILE+1 IF (ISTART) CALL LEOT C NOTE: IF IT IS LOGICAL END OF TAPE, SUBROUTINE WILL TERMINATE C EXECUTION WITHOUT A RETURN. C IF NOT LEOT, WE WILL GO BACK AND ASK IF FILES SHOULD BE SKIPPED. 230 IF (ICHAR.EQ.0) GO TO 130 C C NOPE, NOT A MARK. SET A FEW FLAGS. C ISTART=.FALSE. ITRY=ITRY+1 C C SHOULD IT BE EBCDIC? C IF (.NOT.EBCDIC) GO TO 240 DO 200 I=1,ICHAR IDATA(I)=ITABLE(IDATA(I)+129) 200 CONTINUE C C DISPLAY WHAT WE'VE GOT. C 17 FORMAT (' THIS BLOCK HAS',I6,' CHARACTERS. IT BEGINS WITH:') 240 WRITE (5,17) ICHAR WRITE (5,3) 18 FORMAT (' ',72A1) WRITE (5,18)(IDATA(I),I=1,72) WRITE (5,3) C C DOES THE USER WANT THIS BLOCK C 19 FORMAT ('$WANT THIS BLOCK (Y/N)? ') 250 WRITE (5,19) READ (5,2) ANS IF (NTYN(ANS)) GO TO 250 C C NO, DOESN'T LIKE IT AT ALL C IF ((ANS(1).EQ.'N').AND.(ITRY.LT.4)) GO TO 220 IF (ANS(1).EQ.'Y') GO TO 310 20 FORMAT ('$THIS WAS YOUR FOURTH TRY. GO TO NEW FILE (Y/N)? ') 260 WRITE (5,20) READ (5,2) ANS IF (NTYN(ANS)) GO TO 260 ITRY=0 IF (ANS(1).EQ.'N') GO TO 220 C ******UNUSUAL BRANCH. USER WANTS TO KEEP READING. 27 FORMAT ('$WANT TO REWIND TO BOT (Y/N) ?') 270 WRITE (5,27) READ (5,2) ANS IF (NTYN(ANS)) GO TO 270 IF (ANS(1).EQ.'N') GO TO 280 WRITE (5,26) CALL EXTMT(7) IFILE=1 280 IF (ANS(1).EQ.'N') CALL SKIP(-1) GO TO 130 C **************************UNUSUAL BRANCH (UNCONDITIONAL) READ NEW FILE. C C FINALLY, WE CAN WRITE SOME STUFF TO THE DISC. C C RECORD SIZE? C 310 CALL FORM(IREC,FMT) C C OPEN DISC FILE FOR OUTPUT C 22 FORMAT ('$OUTPUT FILE NAME? ') WRITE (5,22) 23 FORMAT (20A1) READ (5,23) FILNAM OPEN (UNIT=1,ACCESS='SEQUENTIAL',NAME=FILNAM,RECORDSIZE=IREC, 1INITIALSIZE=-1) C C NOTE: IF THE FILE NAME IS NOT VALID, A SYSTEM ERROR WILL C TERMINATE THE PROGRAM. THIS IS TO ALLOW SYSTEM C CONVENTIONS TO CHANGE WITHOUT A CORRESPONDING CHANGE C IN THIS PROGRAM. IT'S A FEATURE. C C WRITE CURRENT BLOCK C WRITE (1,FMT)(IDATA(I),I=1,ICHAR) IBLOCK=1 C C PRINT WARNING IF RECORDSIZE NOT OK C NTPRNT=.TRUE. IF (0.EQ.MOD(ICHAR,IREC)) GO TO 320 IF (NTPRNT) WRITE (5,28) NTPRNT=.FALSE. WRITE (5,29) IBLOCK,ICHAR,IREC C C READ IN NEXT BLOCK C 320 CALL EXTMT(1,10200,IDATA,ICHAR) IF (ICHAR.EQ.0) GO TO 350 C C IS IT EBCDIC? C IF (.NOT.EBCDIC) GO TO 330 DO 300 I=1,ICHAR IDATA(I)=ITABLE(IDATA(I)+129) 300 CONTINUE C C WRITE IT TO THE FILE C 330 WRITE (1,FMT)(IDATA(I),I=1,ICHAR) IBLOCK=IBLOCK+1 C C CHECK THAT BLOCKING FACTOR IS OK C IF (0.EQ.MOD(ICHAR,IREC)) GO TO 350 IF (NTPRNT) WRITE (5,28) NTPRNT=.FALSE. WRITE (5,29) IBLOCK,ICHAR,IREC C C WAS THERE A MARK? YES. C 350 IF (ICHAR.NE.0) GO TO 320 24 FORMAT(' MARK --',I6,' BLOCKS READ.') WRITE (5,24) IBLOCK IFILE=IFILE+1 CLOSE (UNIT=1) C C WANT MORE (THE POOR GUY)? C 25 FORMAT ('$READ MORE FILES (Y/N)? ') 360 WRITE (5,25) READ (5,2) ANS IF (NTYN(ANS)) GO TO 360 IF (ANS(1).EQ.'Y') GO TO 130 26 FORMAT ('0...REWINDING TAPE...') WRITE (5,26) CALL EXTMT(7) CALL EXIT 28 FORMAT ('0*** WARNING *** TAPE BLOCKING FACTOR IS NOT A ', 1'MULTIPLE OF RECORD SIZE.',/) 29 FORMAT (' AT BLOCK',I6,': BLOCKING FACTOR =',I6, 1'. RECORD SIZE =',I6,'.') END