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