FTN4 SUBROUTINE TAPER(LU1,TAPE,BUFR,BUFSZ,LEN,EOF,IERR) +,92069-16196 REV.2013 790126 C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18196 C RELOC: 92069-16196 C C C****************************************************************: C C C************************************************** C TAPER READS A MAG TAPE AND PUTS THE DATA INTO BUFR. C IT RETURNS THE LENGTH READ IN LEN, AND RETURNS EOF C AS TRUE IF A LOGICAL EOF IS ENCOUNTERED. C ON ERRORS, IT RETURNS WITH NEGATIVE IN IERR. C C TAPER ASSUMES THE FOLLOWING: C 1) A LOGICAL EOF ON THE TAPE DEVICE IS A -1 LENGTH RECORD. C 2) A LOGICAL EOF ON A TYPE 3 FILE IS A 0-LENGTH RECORD. C 3) A TRUE EOF ON THE TAPE DEVICE IS SET BY THE EOT MARK ON THE TAPE. C 4) A TRUE EOF ON THE TYPE 3 FILE IS A -1 LENGTH RECORD. C************************************************** C NAMED COMMON DECLARATIONS. C INTEGER HDR(24),TDCB(144),TDSZ,P5(6) COMMON/TPHDR/HDR,TDCB,TDSZ,P5 C******************************************************** C FORMAL PARAMETERS. C INTEGER LU1,TAPE(1),BUFR(1),BUFSZ,LEN,IERR LOGICAL EOF C********************************************************** C LOCAL VARIABLES. C INTEGER TEMP(30) INTEGER RESPON C******************************************************** C READ IN BUFFER FROM THE STORAGE DEVICE. C 350 CALL EREAD(TDCB,IERR,BUFR,BUFSZ,LEN) C************************************************************* C TRAP OUT AN EOF ON A TYPE 3 FILE. C ITYPE = TAPE(4) IF ((LEN .EQ. -1) .AND. (ITYPE .EQ. 3)) GO TO 5000 CALL DBER2(LU1,IERR,TAPE,6HTAPER ,2HXX) IF (IERR .LT. 0) RETURN C****************************************************************** C ON A TAPE UNIT ,SEE IF YOU HIT A TRUE EOT. C IF (ITYPE .EQ. 3) GO TO 2000 IA=IEOT(TAPE) IF (IA .LT. 0) GO TO 6000 C*********************************************************** C TEST FOR A LOGICAL EOF MARK. C (0-LENGTH RECORD FOR TYPE 3 FILE, -1 LENGTH FOR A TYPE 0 FILE). C 2000 CONTINUE 300 IF (LEN .EQ. 0) GO TO 3000 IF ((LEN .EQ. -1) .AND. (ITYPE .EQ. 1)) GO TO 3000 C******************************************************** C NORMAL RETURN POINT.TEST IF USER SET A BREAKPOINT. C IF (IFBRK(IDUMY)) 7000,3500 C*********************************************************** C LOGICAL EOF WAS ENCOUNTERED. C 3000 CONTINUE EOF=.TRUE. IERR=0 3500 RETURN C*************************************************************** C HIT A REAL EOF ON THE TYPE 3 FILE. C REMEMBER, RECORD HAS TO BE WRITTEN TO NEW TAPE. (12-12-78) C 5000 CALL EOFRE(LU1,TAPE,HDR,TDCB,TDSZ,P5,IERR) IF(IERR .GE. 0) GO TO 350 RETURN C************************************************************ C HIT A REAL EOT ON THE TAPE DEVICE. C PROCESS THE EOT, REMEMBERING THAT THE DATA IN BUFR IS GOOD DATA. C 6000 CALL EOTRE(LU1,TAPE,HDR,TDCB,TDSZ,P5,IERR) IF (IERR .LT. 0) RETURN GO TO 300 C*************************************************************** C HANDLE A USER SET BREAKPOINT. C 7000 CONTINUE IERR = -247 CALL DBER2(LU1,IERR,6HXXXXXX,6HTAPER ,2HXX) RETURN END