FTN4
      SUBROUTINE TAPEW(LU1,TAPE,BUFR,BUF1,IERR) 
     +,92069-16193 REV.2013 790413
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-18193
C     RELOC:     92069-16193
C 
C 
C****************************************************************:
C 
C 
C******************************************************************** 
C TAPEW WRITES DATA TO TAPE FROM BUFR. TAPEW ASSUMES THAT TDCB
C (IN NAMED COMMON) IS OPEN TO TAPE AS A TYPE 0 FILE IF TAPE IS A MAG 
C TAPE LU, OR AS A TYPE 1 FILE IF TAPE IS A DISC FILE.
C 
C TAPEW CHECKS FOR AN EOF AT THE END OF EACH WRITE, AND PROMPTS THE 
C USER TO MOUNT A NEW TAPE AT EOT, OR ABORTS AT THE END OF A TYPE 1 
C FILE. 
C IF AN EOT OCCURS, THE RECORD IS WRITTEN ON THIS TAPE, NOT THE 
C NEW TAPE. THEN TAPEW WRITES AN EOF ON THE TAPE AND CALLS EOTWR
C TO PROMPT FOR A NEW TAPE. 
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),BUF1,IERR 
C****************************************************************** 
C 
      INTEGER BUFL
      BUFL=BUF1 
C*********************************************************************
C BRANCH TO 5000 IF THE USER SET THE BREAK BIT. 
C 
      IF (IFBRK(IDUMY)) 5000,300
C*********************************************************************
C FOR A 0-LENGTH RECORD TO A TAPE LU, HAVE TO WRITE AN EOF(LENGTH -1) 
C 
300   IF ((BUFL .EQ. 0) .AND. (TAPE(4) .EQ. 1)) BUFL=-1 
C*****************************************************************
C WRITE BUFR TO TAPE USING TDCB.
C 
      CALL EWRIT(TDCB,IERR,BUFR,BUFL) 
C******************************************************** 
C TRAP OUT AN EOF ON A TYPE 3 FILE. 
C 
      IF (IERR .EQ. -33) GO TO 4000 
      CALL DBER2(LU1,IERR,TAPE,6HTAPEW ,2HXX) 
      IF (TAPE(4) .NE. 1) RETURN
C*****************************************************************
C SPECIAL CHECK FOR AN EOT ON THE TAPE DEVICE.
C 
2000  IA=IEOT(TAPE) 
      IF (IA .GE. 0) RETURN 
C************************************************************ 
C END OF TAPE ON A TAPE DEVICE. 
C WRITE EOF ON THIS TAPE(THE RECORD HAS BEEN WRITTEN OVER THE EOT MARK).
C CALL EOTWR TO REQUEST NEW TAPE. 
C RETURN,KNOWING THAT THE NEW TAPE IS READY FOR NEXT WRITE. 
C 
      CONTINUE
      CALL EWRIT(TDCB,IERR,IDUMY,-1)
      CALL DBER2(LU1,IERR,TAPE,6HTAPEW ,2HXX) 
      IF (IERR .LT. 0) RETURN 
      CALL EOTWR(LU1,TAPE,HDR,TDCB,TDSZ,P5,IERR)
      RETURN
C*********************************************************
C TRAP FOR THE EOF ON A TYPE 3 FILE.
C PERFORM THESE STEPS:
C 1) CALL EOFWR TO CLOSE THE CURRENT FILE, THEN REQUEST AND OPEN
C THE NEW FILE, WRITE A TAPE HEADER.
C 2) GO TO THE TOP TO WRITE THE DATA RECORD INTO THE NEW FILE.
C 
4000  CONTINUE
      IF (TAPE(4) .NE. 3) CALL DBER2(LU1,7777,6HXXXXXX,6HTAPEW ,2HAB) 
      CALL EOFWR(LU1,TAPE,HDR,TDCB,TDSZ,P5,IERR)
      IF (IERR .NE. 0) RETURN 
      GO TO 300 
C****************************************************************** 
C USER SET THE BREAK BIT. 
C 
5000  CALL DBER2(LU1,247,6HXXXXXX,6HTAPEW ,2HXX)
      IERR=-247 
      RETURN
      END 
                                                                                                                                    