FTN4 C <800822.0733> C C C *************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * C * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* C * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C *************************************************************** C C C NAME: EDTU0 C SOURCE: 92074-18004 C RELOC: PART OF 92074-12001 C PGMR: J.D.J. C C C C SUBROUTINE TO EXTRACT A NAMR FROM AN OPEN DCB C CALL IS: C CALL ENAMR(DCB,ERROR,NAMR-BLOCK) C NAMR-BLOCK IS THE USUAL TEN-WORD GUY C INTEGER FUNCTION ENAMR(DCB,ERROR,CMDVAL) C,92074-1X004 REV.2034 800818 IMPLICIT INTEGER (A-Z) INTEGER DCB(144),CMDVAL(10) C C CLEAR OUT THE LU, TYPE, SIZE, REC LEN AND EXTRA WORDS C DO 10 I = 6,10 10 CMDVAL(I) = 0 C C CLEAR OUT BIT FIELDS EXCEPT FOR NAME AND SC C CMDVAL(4) = IAND(CMDVAL(4),17B) C C C GET CARTRIDGE C CALL LOCF(DCB,ERROR,IREC,IRB,IOFF,JSEC,JLU,JTY) IF( ERROR .LT. 0 ) GOTO 7000 CMDVAL(6) = CLUCR(JLU) C C GET TYPE C CMDVAL(7) = JTY C C BUILD WORD FULL OF TYPE BITS C CMDVAL(4) = ISHFT(NAMRT(CMDVAL(7)),6) * + ISHFT(NAMRT(CMDVAL(6)),4) * + CMDVAL(4) C C WE DID IT! C ERROR = 0 7000 ENAMR = ERROR RETURN C C HERE ON I/O ERROR C C* 6000 ERROR = -1 C* RETURN END C C TNAMR - TYPES NAMR - CALLS NAMR AND BUILD A CORRECT TYPE FIELD C INTEGER FUNCTION TNAMR(NRBUF,BUF,LNG,CNT) C,92074-1X004 REV.2034 800818 INTEGER NRBUF(10), BUF(1), LNG, CNT C C PARSE WITH NAMR C TNAMR = NAMR(NRBUF,BUF,LNG,CNT) C C LEAVE FILE NAME TYPE ALONE C NRBUF(4) = IAND(NRBUF(4),3B) C C BUILD TYPE FOR REMAINING PARAMS C NRBUF(4) = NRBUF(4) + ISHFT(NAMRT(NRBUF(5)),2) 1 + ISHFT(NAMRT(NRBUF(6)),4) 2 + ISHFT(NAMRT(NRBUF(7)),6) 3 + ISHFT(NAMRT(NRBUF(8)),8) END