FTN4 PROGRAM QY11(5,90),92069-16060 REV.1912 790202 C C C************************************************************* C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C************************************************************* C C C SOURCE: 92069-18074 C RELOC: 92069-16060 C C C************************************************************ C C C DESTROY SERVICE ROUTINE C DIMENSION NAME(2) INTEGER ERR2(22) INTEGER ERR3(7) C C$$$$$$$$$$$$$$$$$$$ NOVEMBER 3,1978 $$$$$$$$$$$$$$$$$$$$$ INTEGER INLU,ITTY,ILP,IDCB,JDCB,XEQ INTEGER DBNAM,DBLEV,DSNAM,DINAM,SELECT,SNAM INTEGER DSNUM,DINUM,PARM,LPARM,ECHO,QSERR INTEGER IMA,IB,IBSZ,SECNO,IEND,ISCAN LOGICAL BREAK INTEGER IPFLAG,IOFLAG,RMOTE LOGICAL BATCH,XQBCH INTEGER PAGCNT,LNCNT INTEGER PAGLEN,COLLIM REAL RRCNT REAL SELT,RSEC INTEGER IPTR REAL RCOUNT INTEGER S,R3,TRKNM,IDILU INTEGER R6 REAL ATOTAL INTEGER LIST,L,T,U INTEGER LEVSTR,LEVLEN INTEGER IBUFF INTEGER SS(7,100) C COMMON INLU(145),ITTY(145),ILP(145),IDCB(145),JDCB(144),XEQ(145) COMMON DBNAM(10),DBLEV(3),DSNAM(3),DINAM(3),SELECT(6),SNAM(3) COMMON DSNUM,DINUM,PARM(40),LPARM,ECHO,QSERR COMMON IMA(37),IB(896),IBSZ,SECNO,IEND,ISCAN COMMON BREAK COMMON IPFLAG,IOFLAG,RMOTE COMMON BATCH,XQBCH COMMON PAGCNT,LNCNT COMMON PAGLEN,COLLIM COMMON RRCNT COMMON SELT(64),RSEC COMMON IPTR COMMON RCOUNT COMMON S(15,50),R3,TRKNM,IDILU COMMON R6 COMMON ATOTAL(6,5) COMMON LIST(101,6),L(7),T(5),U(7,5) COMMON LEVSTR(66,5),LEVLEN(5) COMMON IBUFF(2048) C EQUIVALENCE (S,SS) C$$$$$$$$$$$$$$$$$$$ NOVEMBER 3,1978 $$$$$$$$$$$$$$$$$$$$$ DATA NAME/2HNA,2HME/ DATA ERR2/2H P,2HRO,2HCE,2HDU, 1 2HRE,2H N,2HAM,2HE ,2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H , 2 2H ,2H N,2HOT,2H F,2HOU,2HND/ DATA ERR3/2H S,2HYN,2HTA, 1 2HX ,2HER,2HRO,2HR / C C C C C C C C C C C C BEGIN C C C C DESTROY NAME = C C RETURN TO NEXT? C C C SCAN FOR NAME C CALL LSCAN(IB,I,J,K) IF(J-I.NE.3) GO TO 30 IF (JSCOM(NAME,1,4,IB,I,IERR).EQ.0) GO TO 35 30 CONTINUE IP = 1 34 IF(IEND .LE. 72) GOTO 37 CALL QRIO(2,ITTY,IB(IP),-72) IEND = IEND - 72 IP = IP + 36 GOTO 34 C C WRITE LAST LINE OUT C 37 CALL QRIO(2,ITTY,IB(IP),-IEND) C C CALL SFILL(IMA,1,72,40B) IF(I .GT. 72) I = I- I/72*72 CALL SPUT(IMA,I,136B) CALL QRIO(2,ITTY,IMA,-I) C ERROR - SYNTAX CALL ERIO(2,ITTY,ERR3,7) GO TO 10 C C FMGR ERROR C 25 CALL FMERR(IERR,ITTY) GOTO 10 C C PROCEDURE NOT FOUND C 40 CONTINUE CALL SMOVE(IB,I,J,ERR2,17) CALL ERIO(2,ITTY,ERR2,22) GO TO 10 C C SCAN ACROSS = C 35 CALL LSCAN(IB,I,J,K) IF (K.NE.6) GO TO 30 C C GET PROCEDURE NAME C GTPRM RETURNS A -1 IN IDCB WHEN THE NAME IS A FILE C 0 IN IDCB WHEN THERE WAS NO INPUT C LU IN IDCB WHEN A DEVICE WAS SPECIFIED C RETURNS A DCB IN WORDS 2-145 OF IDCB C OPENS THE FILE AND RETURNS THE ERROR CODE IN IERR C RETURNS THE FILE NAME IN WORDS 1-3 OF IMA C SECURITY CODE IN WORDS 5 OF IMA C CARTRIDGE NUMBER IN WORD 6 OF IMA C CALL LSCAN(IB,I,J,K) IF (K.NE.2) GO TO 30 IPTR = I CALL GTPRM(IMA,IB,J,IPTR,IDCB,IDCB(2),.FALSE.,IERR) IF(IERR .EQ. -200) GOTO 30 IF(IERR .EQ. -6) GOTO 40 IF(IERR .LT. 0) GOTO 25 IF(IDCB .GE. 0) GOTO 30 C C PURGE FILE C CALL PURGE(IDCB(2),IERR,IMA,IMA(5),IMA(6) ) IF (IERR.LT.0) GOTO 25 C C EXIT C 10 CONTINUE SNAM(2) = 2H CALL LOAD(SNAM) END $