FTN4
      PROGRAM QY(5,90),92069-16060 REV.1940 790523
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-18062
C     RELOC:     92069-16060
C 
C 
C************************************************************ 
C 
C 
C  QUERY SUBSYSTEM MAIN MODULE
C  COMMAND INTERPRETER
C 
C 
      LOGICAL IFTTY 
      INTEGER SPACE 
      INTEGER JSEC(4) 
      INTEGER EDITOR(3) 
      INTEGER DUMMY(2)
      INTEGER CMDTBL(89)
      INTEGER INVAL(9)
      INTEGER NDEF(6) 
      INTEGER ISTAT(10) 
      INTEGER MODE(4) 
      INTEGER LEVEL(5)
      INTEGER IERR1(17) 
      INTEGER IERR2(9)
      INTEGER IERR3(15) 
      INTEGER IERR4(11) 
      INTEGER IERR5(7)
      INTEGER IERR6(8),IERR7(9),IERR8(9)
      INTEGER MSG(11) 
      INTEGER YES(2),NO 
      INTEGER NEXT(3) 
      INTEGER IWAIT(25) 
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 SPACE/2H  /
      DATA INVAL(1)/2H I/ 
      DATA INVAL(2)/2HNV/ 
      DATA INVAL(3)/2HAL/ 
      DATA INVAL(4)/2HID/ 
      DATA INVAL(5)/2H C/ 
      DATA INVAL(6)/2HOM/ 
      DATA INVAL(7)/2HMA/ 
      DATA INVAL(8)/2HND/ 
      DATA INVAL(9)/6412B/
C 
      DATA NDEF/2HNO,2HT ,2HDE,2HFI,2HNE,2HD /
      DATA CMDTBL/2HFI,2HND,2H  ,2H  ,2H  ,2H  ,
     &            2HRE,2HPO,2HRT,2H  ,2H  ,2H  ,
     &            2HUP,2HDA,2HTE,2H  ,2H  ,2H  ,
     &            2HCR,2HEA,2HTE,2H  ,2H  ,2H  ,
     &            2HDE,2HST,2HRO,2HY ,2H  ,2H  ,
     &            2HDI,2HSP,2HLA,2HY ,2H  ,2H  ,
     &            2HFO,2HRM,2H  ,2H  ,2H  ,2H  ,
     &            2HEX,2HIT,2H  ,2H  ,2H  ,2H  ,
     &            2HHE,2HLP,2H  ,2H  ,2H  ,2H  ,
     &            2HLI,2HST,2H  ,2H  ,2H  ,2H  ,
     &            2HEX,2HEC,2HUT,2HE ,2H  ,2H  ,
     &            2HSE,2HLE,2HCT,2H-F,2HIL,2HE ,
     &            2HDA,2HTA,2H-B,2HAS,2HE ,2H  ,
     &            2HXE,2HQ ,2H  ,2H  ,2H  ,2H  /
      DATA MODE/2HMO,2HDE,2H =,2H _/
      DATA LEVEL/2HLE,2HVE,2HL ,2H= ,2H_ /
      DATA IMODE/0/ 
      DATA IERR1/2H  ,2HIL,2HLE,2HGA,2HL ,2HSE,2HLE,2HCT,2H F,2HIL, 
     12HE ,2HSI,2HZE,2H O,2HR ,2HTY,2HPE/ 
      DATA IERR2/2H I,2HNV,2HAL,2HID,2H R,2HEQ,2HUE,2HST,2H  /
      DATA IERR3/2H E,2HRR,2HOR,2H R,2HEL,2HEA,2HSI,2HNG, 
     &   2H S,2HYS,2HTE,2HM ,2HTR,2HAC,2HKS/
      DATA IERR4/2H I,2HLL,2HEG,2HAL,2H L,2HOC,2HK ,2HRE,2HQU,
     &   2HES,2HT / 
      DATA IERR5/2H S,2HYN,2HTA,2HX ,2HER,2HRO,2HR /
      DATA IERR6/2H L,2HIS,2HT ,2HFI,2HLE,2H E,2HRR,2HOR/ 
      DATA IERR7/2H S,2HEL,2HEC,2HT ,2HFI,2HLE, 2H E,2HRR,2HOR/ 
      DATA IERR8/2H B,2HAT,2HCH,2H F,2HIL,2HE ,2HER,2HRO,2HR /
      DATA MSG/2H W,2HAI,2HTI,2HNG,2H O,2HN ,2HDA,2HTA,2H B,
     &   2HAS,2HE / 
      DATA NEXT/2HNE,2HXT,2H_ / 
      DATA YES/2HYE,2HS / 
      DATA NO /2HNO/
      DATA IWAIT/2H D,2HAT,2HA ,2HBA,2HSE,2H I,2HS ,2HLO,2HCK,2HED, 
     12H O,2HR ,2HOP,2HEN,2H, ,2HDO,2H Y,2HOU,2H W,2HAN,2HT ,2HTO,
     22H W,2HAI,2HT?/ 
      DATA EDITOR/2HED,2HIT,2HR / 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C BEGIN 
C 
C CLOSE THE PROCEDURE FILE
C 
      CALL ECLOS(IDCB(2)) 
C 
C CLEAR THE PROCEDURE FLAG
C 
      IPFLAG = 0
C 
C CLEAR THE ECHO PROCEDURE FLAG 
C 
      IOFLAG = 0
C 
C UNLOCK THE LIST LU
C 
      CALL LUREQ(RMOTE,0,ILP,IERR)
C 
C RELEASE ALL SYSTEM TRACKS 
C 
      CALL EXEC(5+100000B,-1) 
      GOTO 7100 
C 
C GET THE NEXT INPUT
C 
20    CONTINUE
      IF(.NOT. BATCH) CALL QRIO(2,INLU,NEXT,-5) 
C 
C DECODE COMMAND
C   WHEN THE INPUT IS A SEMICOLN ONLY IT IS ASSUMED THAT
C   A BATCH FILE JUST COMPLETED AND THE NEXT COMMAND IS 
C   GOTTEN
C 
      CALL INPUT
      CALL LSCAN (IB,I,J,K) 
      IF( K .EQ. 5) GOTO 20 
      CALL SFILL(IMA,1,12,40B)
      CALL SMOVE(IB,I,J,IMA,1)
C 
C LOOK THE COMMAND UP IN THE TABLE
C 
      N = 0 
      DO 30 I2 = 1,14*12,12 
      N = N + 1 
      IF (JSCOM(CMDTBL,I2,I2+11,IMA ,1,IERR ) .EQ. 0) GOTO 40 
30    CONTINUE
C 
C INVALID COMMAND 
C 
      CALL ERIO(2,ITTY,INVAL,9) 
      GOTO 20 
C 
C JUMP TABLE
C 
C          FIND  ,REPORT,UPDATE,CREATE,DESTROY
40     GOTO(50,    100,   150,   200,   250,
C         DISPLAY,FORM   ,EXIT   ,HELP
     &    300,    350,    400,   450, 
C         LIST ,EXECUTE,SELECT ,DATA-BASE,XEQ 
     &    500,   500,    500,    500,    500) N 
C 
C 
C 
C 
C 
C 
C COMMAND PROCESSORS
C 
C 
C 
C 
C 
C 
C 
C FIND
C 
50    SNAM(2) = 2H00
      GOTO 800
C 
C REPORT
C 
100   SNAM(2) = 2H02
      GOTO 800
C 
C UPDATE
C 
150   SNAM(2) = 2H07
      GOTO 800
C 
C CREATE PROCEDURE
C 
200   SNAM(2) = 2H09
      GOTO 800
C 
C DESTROY PROCEDURE 
C 
250   SNAM(2) = 2H11
      GOTO 800
C 
C DISPLAY 
C 
300   SNAM(2) = 2H10
      GOTO 460
C 
C FORM
C 
350   SNAM(2) = 2H08
      GOTO 460
C 
C EXIT
C 
400   SNAM(2) = 2H16
      GOTO 800
C 
C HELP
C 
450   SNAM(2) = 2H13
C 
C LOCK THE LIST DEVICE
C 
460   CONTINUE
      CALL LUREQ(RMOTE,1,ILP,IERR)
      IF(IERR .NE. 0) GOTO 7080 
      GOTO 800
C 
C LIST, EXECUTE, SELECT-FILE, DATA-BASE 
C 
500   CONTINUE
      N = N-9 
      CALL LSCAN(IB,I,J,K)
      IF(K .NE. 6   .AND.   N .EQ. 2) GOTO 550
      IF(K .NE. 6) GOTO 7010
C          LIST    ,EXECUTE,SELECT ,DATA-BASE ,  XEQ
      GOTO(520,     550,    600,    650,         700) N 
C 
C 
C LIST
C 
520   CONTINUE
      IF(ILP .LT. 0) CALL ECLOS(ILP(2)) 
      CALL LSCAN(IB,I,J,K)
      CALL GTPRM(IMA,IB,J,I,ILP,ILP(2),.TRUE.,IERR) 
      IF(IERR .LT. 0  .OR.  ILP .EQ. 0) GOTO 7020 
      IF(ILP .GT.0) ILP = ILP+600B
      GOTO 20 
C 
C EXECUTE 
C 
550   CONTINUE
      S = K 
      SNAM(2) = 2H24
      GOTO 800
C 
C SELECT-FILE=
C 
600   CONTINUE
      CALL SFILL(SELECT,1,12,40B) 
      CALL LSCAN(IB,I,J,K)
      IF(K .NE. 2) GOTO 7010
C 
C GET THE FILE NAME 
C 
      CALL NAMR(IMA,IB,J,I) 
      IF(IAND(IMA(4),3B) .NE. 3) GOTO 7010
      CALL OPEN(JDCB,IERR,IMA,0,IMA(5),IMA(6) ) 
      IF(IERR .GE. 0) GOTO 610
      IF(IERR .NE. -6) GOTO 7040
      IF(IMA(8) .EQ. 0) IMA(8) = 6
      CALL ECREA(JDCB,IERR,IMA,DBLEI(IMA(8)),1,IMA(5),IMA(6)) 
      IF(IERR .LT. 0) GOTO 7040 
C 
C VERIFY TYPE 
C 
610   CONTINUE
      CALL ELOCF(JDCB,ISTAT,DUMMY,DUMMY,
     &             DUMMY,JSEC,DUMMY,JTYP,JREC)
      IF((DCO(JSEC,DBLEI(6)).LT. 0) .OR. (JTYP  .NE. 1) ) GOTO 7035 
      CALL SMOVE(IMA,1,12,SELECT,1) 
      GOTO 20 
C 
C DATA-BASE=
C 
650   CONTINUE
      CALL LSCAN(IB,I,J,K)
      IF(K .NE. 2) GOTO 7010
C 
C CLOSE THE DATA BASE IF NECESSARY
C 
      IF(DBNAM(2) .EQ. SPACE) GOTO 660
      CALL DBCLS(DBNAM,DUMMY,1,ISTAT) 
      IF(ISTAT .NE. 0) GOTO 7070
C 
C PUT NAME IN BUFFER
C 
660   CONTINUE
      CALL SFILL(DBNAM,1,20,40B)
      CALL SMOVE(IB,I,J,DBNAM,3)
C 
C VERIFY SEMICOLN 
C 
      CALL LSCAN(IB,I,J,K)
      IF(K .NE. 5) GOTO 7050
C 
C GET LEVEL WORD, SUPRESSING THE ECHO WHEN INTERACTIVE
C 
      IF(BATCH) GOTO 665
      CALL QRIO(2,INLU,LEVEL,-9)
      INLU = INLU - 400B
665   CALL LSCAN(IB,I,J,K)
      IF(.NOT. BATCH) INLU = INLU + 400B
C 
C SEE IF A ";" WAS ENTERED
C 
      CALL SFILL(DBLEV,1,6,40B) 
      IF(K .EQ. 5) GOTO 667 
      IF(J-I+1 .GT. 6) GOTO 7050
      CALL SMOVE(IB,I,J,DBLEV,1)
C 
C VERIFY SEMICOMMA
C 
      CALL LSCAN(IB,I,J,K)
      IF(K .NE. 5) GOTO 7050
C 
C GET THE MODE
C 
667   CONTINUE
      IF(.NOT. BATCH) CALL QRIO(2,INLU,MODE,4)
      CALL LSCAN(IB,I,J,K)
      IF(I .NE. J) GOTO 7050
      CALL SGET(IB,I,IMODE) 
      IMODE = IMODE - 60B 
      IF( (IMODE .LT. 1) .OR. ( IMODE .GT. 8) ) GOTO 7050 
C 
C VERIFY SEMICOMMA
C 
      CALL LSCAN(IB,I,J,K)
      IF(K .NE. 5) GOTO 7050
C 
C OPEN THE DATA BASE
C 
      CALL DBOPN(DBNAM,DBLEV,IMODE,ISTAT) 
      IF(ISTAT .EQ. 0) GOTO 690 
      IF(ISTAT .NE. 129) GOTO 7070
C 
C DATA BASE IS LOCKED 
C 
670   CONTINUE
      IF(BATCH) GOTO 680
      CALL QRIO(2,INLU,IWAIT,25)
      CALL INPUT
      CALL LSCAN(IB,I,J,K)
      IF(JSCOM(IB,I,I+1,YES,1,IERR) .EQ. 0) GOTO 680
      IF(JSCOM(IB,I,I+1,NO,1,IERR) .EQ. 0) GOTO 7055
      GOTO 670
C 
C WAIT A WHILE
C 
680   CONTINUE
      CALL QRIO(2,ITTY,MSG,11)
685   CONTINUE
      CALL EXEC(12,0,2,0,-10) 
      CALL DBOPN(DBNAM,DBLEV,IMODE,ISTAT) 
      IF(ISTAT .EQ. 129) GOTO 685 
      IF(ISTAT .NE. 0) GOTO 7070
C 
C DONE WITH THE OPEN, SAVE THE LEVEL WORD NUMBER
C 
690   CONTINUE
      DBLEV = ISTAT(2)
      GOTO 20 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C XEQ 
C 
700   CONTINUE
      IF(XEQ .NE. 0) GOTO 710 
C 
C SAVE THE INPUT DCB
C 
      CALL SMOVE(INLU,1,290,XEQ,1)
      XQBCH = BATCH 
      GOTO 720
C 
C CLOSE THE DATA BASE 
C 
710   CONTINUE
      CALL ECLOS(INLU(2)) 
C 
C OPEN THE FILE 
C 
720   CONTINUE
      CALL LSCAN(IB,I,J,K)
      IF(K .NE. 2) GOTO 7010
      CALL GTPRM(IMA,IB,J,I,INLU,INLU(2),.FALSE.,IERR)
      IF(IERR .LT. 0) GOTO 7090 
C 
C ONLY ALLOW FILES AS XEQ INPUT 
C 
      IF(INLU .GT. -1) GOTO 7090
C 
C SET THE BATCH FLAG
C 
      BATCH = .TRUE.
      GOTO 20 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C LOAD AND EXECUTE A SEGEMENT 
C 
800   CONTINUE
      CALL LOAD(SNAM) 
C 
C SYNATAX ERROR 
C 
7010  CONTINUE
      IP = 1
7014  IF(IEND .LE. 72) GOTO 7017
      CALL QRIO(2,ITTY,IB(IP),-72)
      IEND = IEND - 72
      IP = IP + 36
      GOTO 7014 
C 
C WRITE LAST LINE OUT 
C 
7017  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)
      CALL ERIO(2,ITTY,IERR5,7 )
      GOTO 20 
C 
C BAD LIST FILE 
C 
7020  CONTINUE
      CALL ERIO(2,ITTY,IERR6,8) 
      GOTO 7095 
C 
C IVALID REQUEST
C 
7030  CONTINUE
      CALL ERIO(2,ITTY,IERR2,9) 
      GOTO 20 
C 
C BAD SELECT FILE 
C 
7035  CONTINUE
      CALL ERIO(2,ITTY,IERR1,17)
      SELECT=2H 
      GOTO 20 
C 
C SELECT FILE ERROR 
C 
7040  CONTINUE
      CALL ERIO(2,ITTY,IERR7,9) 
      SELECT = 2H 
      GOTO 7095 
C 
C ILLEGAL LEVEL WORD,OR MODE WORD 
C  OUTPUT "INVALID REQUEST" 
C 
7050  CONTINUE
      CALL ERIO(2,ITTY,IERR2,9) 
7055  DBNAM = 2H
      DBNAM(2) = 2H 
      GOTO 20 
C 
C DBMS - ERROR
C 
7070  CONTINUE
      DBNAM = 2H
      DBNAM(2) = 2H 
      QSERR =  ISTAT
      SNAM(2) = 2H23
      GOTO 800
C 
C ILLEGAL LOCK
C 
7080  CONTINUE
      CALL ERIO(2,ITTY,IERR4,11)
      GOTO 20 
C 
C ILLEGAL XEQ FILE
C 
7090  CONTINUE
      CALL ERIO(2,ITTY,IERR8,9 )
      CALL SMOVE(XEQ,1,290,INLU,1)
      XEQ = 0 
      BATCH = XQBCH 
C 
C FMP ERROR 
C 
7095  CONTINUE
      QSERR = IERR
      SNAM(2) = 2H23
      GOTO 800
C 
C OUTPUT "ERROR RELEASING SYSTEM TRACKS"
C 
7100  CONTINUE
      CALL ERIO(2,ITTY,IERR3,15)
      GOTO 20 
      END