FTN4
      PROGRAM QY13(5,90),92069-16060 REV.1912 781114
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-18076
C     RELOC:     92069-16060
C 
C 
C************************************************************ 
C 
C 
C  HELP SERVICE ROUTINE 
C 
      INTEGER CMND(2),FILE(3),DIR(128)
      INTEGER KDCB(144) 
      INTEGER IBUF(128) 
      INTEGER ERR1(9),ERR2(7) 
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   $$$$$$$$$$$$$$$$$$$$$
C 
      DATA FILE/2HQS,2HHE,2HLP/ 
      DATA CMND/2H  ,2H  /
C 
C COMMAND NOT FOUND 
      DATA ERR1/2H C,2HOM,2HMA,2HND,2H N,2HOT,2H F,2HOU,2HND/ 
C SYNTAX ERROR
      DATA ERR2/2H S,2HYN,2HTA,2HX ,2HER,2HRO,2HR / 
C 
C 
C 
C 
C BEGIN 
C 
C 
      LIST = 0
C 
C  SCAN FOR ; OR NAME 
C 
      CALL LSCAN(IB,I,J,K)
      IF(K .EQ. 2) GOTO 10
      IF(K .EQ. 5) GOTO 60
      GOTO 7010 
C 
C     MOVE NAME TO CMND 
C 
   10 CONTINUE
      CALL SFILL(CMND,1,4,40B)
      IF(I+3 .LT. J) J = I + 3
      CALL SMOVE(IB,I,J,CMND,1) 
   15 CALL LSCAN(IB,I,J,K)
      IF(K .EQ. 2) GOTO 20
      IF(K .EQ. 5) GOTO 60
      GOTO 7010 
   20 IF (JSCOM(IB,I,I+1,2HAL,1,IERR).NE.0) GO TO 30
      LIST = 111
      GO TO 60
   30 IF (JSCOM(IB,I,I+1,2HFU,1,IERR).NE.0) GO TO 40
      LIST = LIST + 100 
      GO TO 15
   40 IF (JSCOM(IB,I,I+1,2HSY,1,IERR).NE.0) GO TO 50
      LIST = LIST + 10
      GO TO 15
   50 IF (JSCOM(IB,I,I+1,2HOP,1,IERR).NE.0) GO TO 15
      LIST = LIST + 1 
      GO TO 15
   60 IF (LIST.EQ.0 .OR. LIST.EQ.111) LIST = 111
C 
C     GET DIRECTORY 
C 
      CALL OPEN(KDCB,IERR,FILE) 
61    IF (IERR.GE.0) GOTO 65
      CALL FMERR(IERR,ITTY) 
      GOTO 120
65    CALL READF(KDCB,IERR,DIR,128,ILEN,1)
      IF (IERR.LT.0) GOTO 61
C 
C  LSEC   DATA FILE SECTOR LIMIT
C  NWDS   NO OF WORDS/DIRENTRY ENTRY
C  NEXT   NO OF DIRECTORY ENTRIES 
C  ILIM   IDRECTORY LIMIT IN WORDS
C  IPNT   POINTER TO REL SECTOR OF DATA 
C 
      LSEC=DIR(2) 
      NENT=DIR(3) - 1 
      NWDS=DIR(4) 
      ILIM=NWDS*NENT + 7
      IF (CMND(1).NE.2H  ) GO TO 80 
   70 IOUT=1
      ISEC=DIR(7) 
      GO TO 170 
   80 DO 110 J=8,ILIM,NWDS
      IF (DIR(J)-CMND(1)) 110,90,110
   90 IF (DIR(J+1)-CMND(2)) 110,100,110 
  100 IPNT=J+2
      GO TO 130 
  110 CONTINUE
C 
C     OUTPUT "COMMAND NOT FOUND"
C 
115   CALL ERIO(2,ITTY,ERR1,9)
C 
  120 CALL CLOSE(KDCB)
      SNAM(2)=2H
      CALL LOAD(SNAM) 
C 
  130 IF (LIST.LT.100) GO TO 140
      ISEC=DIR(IPNT)
      LIST=LIST-100 
      GO TO 160 
  140 IF (LIST.LT.10) GO TO 150 
      ISEC=DIR(IPNT+1)
      LIST=LIST-10
      GO TO 160 
  150 IF (LIST.LT.1) GO TO 120
      ISEC=DIR(IPNT+2)
      LIST=LIST-1 
  160 IOUT=2
C 
C  READ 128 WORDS FROM THE DISC INTO IBUF AND 
C  RESET THE POINTER TO THE START OF THE BUFFER 
C 
  170 IPNTR=1 
      CALL READF(KDCB,IERR,IBUF,128,ILEN,ISEC)
      IF(IERR.LT.0) GOTO 61 
C 
C  PICK UP RECORD LENGTH (WORDS) AND
C  SUBSTITUTE BLANKS
C 
  180 ILGTH=IBUF(IPNTR) 
      IBUF(IPNTR)=2H
C 
C  OUTPUT THE RECORD AND UPDATE THE POINTER 
C  TO THE NEXT RECORD COUNT WORD
C 
      ILGTH=ILGTH+1 
      CALL QRIO(2,ILP,IBUF(IPNTR),ILGTH)
      IPNTR=IPNTR+ILGTH 
C 
C  IF NEXT WORD COUNT = -1 INPUT NEXT SECTOR
C                        0 END OF DATA
C                        + OUTPUT NEXT RECORD 
C 
      IF (IBUF(IPNTR)) 190,200,180
  190 ISEC=ISEC+1 
      GO TO 170 
  200 GO TO (120,130), IOUT 
C 
C 
C 
C 
C ERROR PROCESSOR 
C 
7010  CONTINUE
      CALL QRIO(2,ITTY,IB,-IEND)
      IF(I .GT. 72) I = I-I/72*72 
      CALL SFILL(IMA,1,72,40B)
      CALL SPUT(IMA,I,136B) 
      CALL QRIO(2,ITTY,IMA,-I)
      CALL ERIO(2,ITTY,ERR2,7)
      GOTO 120
      END 
$ 
                                                                                                                                                                                