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 MODIFIED APRIL 1983 BY: RONALD HOEKSEMA C C Removed all references to EXTMT function. c Added routine DOTAPE . C DOTAPE uses RT-11 functions to control all the tape C movements and reports on location of tape problem C if a problem is found. C C ************************************************************************ C C C DIMENSION, INITIALIZE C COMMON IDATA,ICHAR,IFILE,NBLOCK 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 FEATURE) 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 DOTAPE TO SEE THAT WE ARE ON LINE, ETC. BEFORE ANY C SERIOUS WORK IS DONE. C CALL DOTAPE(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 DOTAPE(1) 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 DOTAPE(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,CARRIAGECONTROL='LIST') 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 DOTAPE(1) 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 DOTAPE(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 C C ************************************************************************ C SUBROUTINE SKIP(NFILES) C C THIS SUBROUTINE READS THE TAPE, BLOCK-BY-BLOCK, IN A SEARCH FOR TAPE C MARKS. A TAPE MARK IS INDICATED BY NO CHARACTERS READ (ICHAR.EQ.0) C BETWEEN INTER-BLOCK GAPS. C C THE ROUTINE LOOKS NFILES TIMES FOR MARKS. C TWO MARKS IN A ROW COULD INDICATE LOGICAL END OF TAPE. THIS IS C COVERED. IF NOT, WE COULD SPIN TO THE END OF THE REEL. C C C NOTE: NFILES MAY BE -1. THIS DISABLES THE LEOT CHECK AND C SKIPS ONE FILE ONLY. THIS IS USED BY MAIN PROGRAM C TO ALLOW THE USER TO GET OUT OF A LOOP. C C C COMMON, DIMENSION C COMMON IDATA,ICHAR,IFILE,NBLOCK DIMENSION IDATA(10200),ANS(1) LOGICAL*1 IDATA,ANS C C IF NO FILES ARE REQUESTED, RETURN C IF (NFILES.EQ.0) GO TO 160 C C LOOP UNTIL MARK IS FOUND C 110 IBLOCK=0 120 CALL DOTAPE(1) IF (ICHAR.EQ.0) GO TO 130 IBLOCK=IBLOCK+1 130 IF (ICHAR.NE.0) GO TO 120 C C MARK FOUND, TELL USER. C 11 FORMAT (' MARK --',I6,' BLOCKS READ.') WRITE (5,11) IBLOCK NFILES=NFILES-1 IFILE=IFILE+1 C IF NOT IN FIRST BLOCK, AND WE HAVE MORE FILES, GO BACK IF ((IBLOCK.NE.0).AND.(NFILES.GT.0)) GO TO 110 C C IF NO BLOCKS WERE READ, WE BETTER ASK USER IF IT IS LEOT C C NOTE: IF IT IS LEOT, SUBROUTINE LEOT WILL TERMINATE C PROGRAM EXECUTION WITHOUT A RETURN. C IF ((IBLOCK.EQ.0).AND.(NFILES.GE.0)) CALL LEOT C C FINAL CHECK FOR MORE FILES TO READ (NEEDED IF WE RETURN FROM LEOT) C IF (NFILES.GT.0) GO TO 110 160 RETURN END C C ********************************************************************** C SUBROUTINE LEOT C C IF WE ARE HERE, TWO TAPE MARKS WERE FOUND IN A ROW OR A TAPE MARK WAS C THE FIRST THING FOUND ON THE TAPE. THE USER IS GIVEN THE OPTION TO C KEEP GOING (AND POSSIBLY SPIN THE TAPE UNTIL THE END OF THE REEL). C C NOTE: IF IT IS LEOT, THIS SUBROUTINE WILL REWIND TAPE AND TERMINATE C EXECUTION OF TAPER. C C DIMENISON, COMMON C COMMON IDATA,ICHAR,IFILE,NBLOCK DIMENSION IDATA(10200),ANS(1) LOGICAL*1 IDATA,ANS C C TELL USER C 11 FORMAT ('0',5X,'*** WARNING *** POSSIBLE LOGICAL END OF TAPE.') WRITE (5,11) 12 FORMAT (' ') WRITE (5,12) 13 FORMAT ('$READ ON (Y/N)? ') 2 FORMAT (A1) 110 WRITE (5,13) READ (5,2) ANS IF ((ANS(1).NE.'Y').AND.(ANS(1).NE.'N')) GO TO 110 IF (ANS(1).EQ.'Y') GO TO 150 C C WE ARE AT LOT! *********REWIND AND TERMINATE********* C 5 FORMAT (' LEOT LIKELY AFTER FILE',I6,' ...REWINDING TAPE...') IF (IFILE.NE.1) WRITE (5,5) IFILE-2 CALL DOTAPE(7) 6 FORMAT ('0START PROGRAM TO READ TAPE AGAIN.') WRITE (5,6) CALL EXIT C ********* C 150 RETURN END C C ********************************************************************* C SUBROUTINE FORM (IREC,FMT) C C THIS ROUTINE CREATES THE OBJECT TIME FORMAT FOR WRITING FILES TO DISC. C IT ALLOWS FOR RECORDS OF UP TO 1020 CHARACTERS. C IF YOU NEED MORE, EXPAND THIS SECTION. C C DIMENSION C DIMENSION FMT(30) COMMON IDATA,ICHAR,IFILE,NBLOCK C C WHAT RECORD SIZE IS WANTED? C 11 FORMAT ('$RECORD SIZE ? ') 110 WRITE (5,11) 12 FORMAT (I5) 120 READ (5,12) IREC IF (IREC.GT.1020) WRITE (5,1) IF (IREC.GT.1020) GO TO 110 IF (IREC.GT.132) WRITE (5,2) C C WHAT ARE THESE FORMATS? C 255 FORMAT('(',I4,'A1)') 510 FORMAT('(255A1,',I4,'A1)') 765 FORMAT('(255A1,255A1,',I4,'A1)') 1020 FORMAT ('(255A1,255A1,255A1,',I4,'A1)') C C AND NOW, LET'S SELECT THE FORMAT FOR US C IF (IREC.LE.255) ENCODE (8,255,FMT) IREC IF ((IREC.GE.256).AND.(IREC.LE.510)) 1 ENCODE (14,510,FMT) IREC-255 IF ((IREC.GE.511).AND.(IREC.LE.765)) 1 ENCODE (20,765,FMT) IREC-510 IF ((IREC.GE.766).AND.(IREC.LE.1020)) 1 ENCODE (26,1020,FMT) IREC-765 IF (IREC.GT.1020) WRITE (5,1) C 1 FORMAT (' RECORD SIZE MAY NOT EXCEED 1020 CHARACTERS.') 2 FORMAT (' *** WARNING *** RECORD SIZE OF MORE THAN 132 MAY', 1' YIELD UNPREDICTABLE RESULTS.') IF (IREC.GT.1020) STOP 'FATAL ERROR IN RECORD SIZE.' C C NOTE: RECORD SIZE IS TESTED HERE SO THAT IT MAY BE CHANGED BY USER. RETURN END C C *********************************************************************** C SUBROUTINE DOTAPE(IFUN) 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: 1= READ BLOCK C 4= SPACE FORWARD C 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(5100) 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=5100 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) NBLOCK=NBLOCK+1 C C C RETURN PROPER VALUES FOR NUMBER CHARACTERS READ C IWCNT=0 IF(ERRBLK(1).EQ.6)IWCNT=(5100-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