FTN4
      SUBROUTINE EOFWR(LU1,TAPE,HDR,TDCB,TDSZ,P5,IERR)
     +,92069-16195 REV.2013 800107
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-18195
C     RELOC:     92069-16195
C 
C 
C****************************************************************:
C 
C 
C**************************************************************** 
C EOFWR HANDLES AN EOF ON A WRITE TO A TYPE 3 FILE. 
C EOFWR DOES THESE STEPS: 
C 1) CALLS ELOCF TO DETERMINE THE NEXT AVAILABLE RECORD (EOFWR
C    ASSUMES THAT ELOCF RETURNS THE NEXT AVAILABLE RECORD IF THE
C    LAST WRITE RETURNED AN ERROR I.E. THAT THE LAST THING EWRIT DOES 
C    IS UPDATE THE INFORMATION ON THE RECORD NUMBER). 
C 2) POSITIONS THE FILE TO THE NEXT AVAILABLE RECORD. 
C 3) WRITES AN EOF MARK IN THIS POSITION, AND CLOSES THE FILE.
C 4) PROMPTS THE USER FOR ANOTHER FILE NAME.
C 5) CREATES A NEW FILE WITH THE NAME AND CARTRIDGE SPECIFIED THAT
C    TAKES UP THE ENTIRE REST OF THE CARTRIDGE (A DIFFERENT CARTRIDGE 
C    THAN THE PREVIOUS ONE SINCE THERE'S NO ROOM LEFT ON THAT ONE.) 
C 6) OPENS THE FILE AND WRITES A TAPE HEADER INTO THE FILE. 
C*****************************************************************
      INTEGER LU1,TAPE(1),HDR(1),TDCB(1),TDSZ,P5,IERR 
C*****************************************************************
C LOCAL VARIABLES.
C 
      INTEGER IREC(2) 
      INTEGER FILE(20)
      DOUBLE PRECISION MESS1(6) 
      INTEGER MESS2(18) 
      EQUIVALENCE(MESS1,MESS2)
C****************************************************************** 
C DATA STATEMENTS 
      DATA MESS1/6H SAVE ,6HFILE  ,6H      ,6H  AS  ,6H      ,6H      / 
C****************************************************************** 
      IF (TAPE(4) .NE. 3) CALL DBER2(LU1,7777,6HXXXXXX,6HEOFWR ,2HXX) 
      IF (P5 .EQ. 2HAB) GO TO 9000
C*******************************************************************
C CALL ELOCF TO GET WHERE THE LAST WRITE WAS ATTEMPTED. 
C 
      CALL ELOCF(TDCB,IERR,IREC)
      CALL DBER2(LU1,IERR,TAPE,6HEOFWR ,2HXX) 
C*****************************************************************
C POSITION THE FILE TO WHERE THE WRITE SHOULD HAVE OCCURRED.
C 
      CALL RWNDF(TDCB,IERR) 
      CALL EPOSN(TDCB,IERR,IREC,1)
      CALL DBER2(LU1,IERR,TAPE,6HEOFWR ,2HXX) 
C************************************************************ 
C WRITE OUT AN EOF. 
C 
      CALL EWRIT(TDCB,IERR,IDUMMY,-1) 
      CALL DBER2(LU1,IERR,TAPE,6HEOFWR ,2HXX) 
      CALL POST(TDCB,IERR)
      CALL ECLOS(TDCB,IERR) 
      CALL DBER2(LU1,IERR,TAPE,6HEOFWR ,2HXX) 
      IF (IERR .LT. 0) RETURN 
C****************************************************************** 
C TELL USER TO REMEMBER THE OLD FILE. 
C 
      MESS2(7)=TAPE(1)
      MESS2(8)=TAPE(2)
      MESS2(9)=TAPE(3)
      MESS2(13)=HDR(9)
      MESS2(14)=HDR(10) 
      MESS2(15)=HDR(11) 
      CALL CNUMD(HDR(21),MESS2(16)) 
      CALL REIO(2,LU1,MESS1,18) 
C*******************************************************************
C REQUEST THE NEXT FILE NAME. 
C 
1000  CALL REIO(2,LU1,35H NEXT STORAGE FILE(AB TO ABORT) ? _,-35) 
      CALL REIO(1,LU1+400B,FILE,20) 
      CALL ABREG(IA,IB) 
      LNGTH2=2*IB 
      IF ((LNGTH2 .EQ. 2) .AND. (FILE(1) .EQ. 2HAB)) GO TO 9000 
      ISTRC1=1
      CALL PRAM(LU1,FILE,LNGTH2,ISTRC1,TAPE)
      IF (TAPE(4) .EQ. 3) GO TO 2000
      CALL REIO(2,LU1,28H PLEASE SPECIFY A FILE NAME.,-28)
      GO TO 1000
C************************************************************** 
C HAVE A GOOD FILE NAME. MAKE A NEW FILE AND OPEN IT. 
C 
2000  CONTINUE
      CALL NWFIL(LU1,IERR,TDCB,TDSZ,TAPE,DBLEI(-1),3,P5)
      IF (IERR .LT. 0) GO TO 1000 
      IOPTN=100B
      CALL OPENF(TDCB,IERR,TAPE,IOPTN,TAPE(5),TAPE(6),TDSZ) 
      IF (IERR .GT. 0) IERR=0 
      CALL DBER2(LU1,IERR,TAPE,6HEOFWR ,2HXX) 
      IF (IERR .LT. 0) GO TO 1000 
C***************************************************************
C WRITE OUT A TAPE HEADER ON THE NEW FILE.
C 
      HDR(21)=HDR(21)+1 
      CALL EWRIT(TDCB,IERR,HDR,24)
      CALL DBER2(LU1,IERR,TAPE,6HEOFWR ,2HXX) 
      RETURN
C*****************************************************************
C ABORT POINT.
C 
9000  CONTINUE
      IERR=-235 
      CALL REIO(2,LU1,25H ABORTING AT END OF FILE.,-25) 
      CALL DBER2(LU1,235,6HXXXXXX,6HEOFWR ,2HXX)
      RETURN
      END 
                                                                                                                                                  