FTN4
      SUBROUTINE FILEH(LU1,TAPE,NAMR,DCB2,DCB2SZ,J,IERR)
     +,92069-16202 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-18202
C     RELOC:     92069-16202
C 
C 
C****************************************************************:
C 
C 
C***********************************************************
C FILEH WRITES A FILE HEADER TO TAPE. 
C IT USES THE INFORMATION IN NAMR TO OPEN THE FILE, THEN
C CALLS ELOCF TO DETERMINE THE TYPE, SIZE, AND RECORD SIZE
C OF THE FILE.
C 
C JSEC= 2-WORD INTEGER WITH NUMBER OF SECTORS IN FILE NAMR. 
C JBLK= 2-WORD INTEGER WITH NUMBER OF BLOCKS IN FILE (JSEC/2).
C 
C***********************************************************
      INTEGER LU1,TAPE(1),NAMR(1),DCB2(1),DCB2SZ,J,IERR 
      COMPLEX STRING(6) 
      INTEGER S(24) 
      INTEGER IREC(2),IRB(2),JSEC(2),JBLK(2)
      REAL BLK
      EQUIVALENCE(JBLK,BLK) 
      EQUIVALENCE (STRING,S)
      DATA STRING/8HFILEHEAD,8H21XX    ,4*8H        / 
C************************************************************ 
C OPEN UP THE FILE AND CALL ELOCF TO GET DATA.
C 
      ISECU=NAMR(5) 
      ICR=NAMR(6) 
      IOPTN=0 
      CALL OPENF(DCB2,IERR,NAMR,IOPTN,ISECU,ICR,DCB2SZ) 
      IF (IERR .LT. 0) GO TO 9000 
      CALL ELOCF(DCB2,IERR,IREC,IRB,IOFF,JSEC,JLU,JTY,JREC) 
      IF (IERR .LT. 0) GO TO 9000 
      BLK=DDI(JSEC,DBLEI(2))
C********************************************************** 
C SET UP THE STRING TO BE WRITTEN 
C 
      DO 10 K=1,6 
      S(K+8)=NAMR(K)
10    CONTINUE
      S(17)=J 
      S(19)=JREC
      S(20)=JTY 
      S(21)=JBLK(1) 
      S(22)=JBLK(2) 
      S(24)=2H**
C*********************************************************
C WRITE IT TO TAPE. 
C 
      CALL TAPEW(LU1,TAPE,S,24,IERR)
      CALL ECLOS(DCB2,IERR) 
      RETURN
C***********************************************************
C ERROR.
C 
9000  CALL DBER2(LU1,IERR,NAMR,6HFILEH ,2HXX) 
      CALL ECLOS(DCB2,IERR2)
      RETURN
      END 
                                                                                                                                                                                              