FTN4 PROGRAM QY00(5,90),92069-16060 REV.1940 790523 C C C 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-18063 C RELOC: 92069-16060 C C C************************************************************ C C C FIND COMMAND SERVICE MODULE C QS00 C QS01 C C THE PURPOSE OF THIS MODULE IS TO BREAK DOWN C A FIND PROCEDURE (IN DISJUNCTIVE NORMAL FORM) C INTO A TABLE OF ELEMENTARY CONJUNCTS AND C DISJUNCTS. THIS TABLE WILL BE USED BY A C 'SEARCH' MODULE TO RETRIEVE RECORDS FROM A C DATA BASE. C LOGICAL ISPTH,MEMBR INTEGER IBUF(51) INTEGER BUFF(130) INTEGER SAVBF(130) INTEGER SAVE(5) INTEGER ISTAT(10) INTEGER FIND(2) INTEGER NAME(2) INTEGER AND(2),OR,END(2) INTEGER INE(2),ILT(2),INLT(2),IGT(2),INGT(2) INTEGER INA(3) INTEGER IREG(2) INTEGER ERR1(14) INTEGER ERR2(12) INTEGER ERR3(15) INTEGER ERR4(14) INTEGER ERR6(22) INTEGER ERR7(16) INTEGER ERR8(14) INTEGER ERR9(13) INTEGER ERR10(19) INTEGER ERR11(12) INTEGER ERR12(19) INTEGER ERR13(13) INTEGER ERR16(19) INTEGER ERR18(7) INTEGER ERR19(27) INTEGER ERR20(15) INTEGER R,X,D INTEGER FIND INTEGER VALUE(11) 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 $$$$$$$$$$$$$$$$$$$$$ EQUIVALENCE (REG,IREG,IA),(IREG(2),LEN) DATA AND(1),AND(2)/2HAN,2HD / DATA OR/2HOR/ DATA END/2HEN,2HD;/ DATA IS/2HIS/ DATA IE/2HIE/ DATA INE(1),INE(2)/2HIN,2HE / DATA ILT(1),ILT(2)/2HIL,2HT / DATA INLT(1),INLT(2)/2HIN,2HLT/ DATA IGT(1),IGT(2)/2HIG,2HT / DATA INGT(1),INGT(2)/2HIN,2HGT/ DATA INA(1),INA(2),INA(3)/2HIS,2HNO,2HT / DATA ERR1/2H N,2HO ,2H A,2HVA,2HIL,2HAB,2HLE,2H S,2HYS,2HTE,2HM , & 2HTR,2HAC,2HKS/ DATA ERR2/2H F,2HIN,2HD ,2HPR,2HOC, 1 2HED,2HUR,2HE ,2HTO,2HO ,2HLO,2HNG/ DATA ERR3/2H I,2HLL,2HEG,2HAL,2H D, 1 2HAT,2HA ,2HIT,2HEM,2H N,2HAM,2HE , 2 2HXX,2HXX,2HXX/ DATA ERR4/2H R,2HEL,2HAT,2HIO,2HNA,2HL , 1 2HOP,2HER,2HAT,2HOR,2H I,2HNV,2HAL,2HID/ DATA ERR6/2H I,2HNV,2HAL,2HID,2H #,2H O, 1 2HF ,2HVA,2HLU,2HES,2H F,2HOR,2H R,2HEL, 2 2HAT,2HIO,2HNA,2HL ,2HOP,2HER,2HAT,2HOR/ DATA ERR7/2HIN,2HVA,2HLI,2HD ,2HLO,2HGI, 1 2HCA,2HL ,2HCO,2HNN,2HEC,2HTO,2HR , 2 2HXX,2HXX,2HXX/ DATA ERR8/2H N,2HOT,2H E,2HNO,2HUG,2HH ,2HSE,2HCT,2HOR,2HS ,2HIN, 12H Q,2HSK,2HIB/ DATA ERR9/2H S,2HEL,2HEC,2HT-,2HFI,2HLE, ERR9 1 2H N,2HOT,2H D,2HEC,2HLA,2HRE,2HD / ERR9 DATA ERR10/2H R,2HET,2HRI,2HEV,2HAL, ERR10 1 2H F,2HRO,2HM ,2HMO,2HRE,2H T,2HHA, ERR10 2 2HN ,2HON,2HE ,2HDA,2HTA,2H-S,2HET/ ERR10 DATA ERR11/2H D,2HAT,2HA-,2HBA,2HSE, 1 2H N,2HOT,2H D,2HEC,2HLA,2HRE,2HD / DATA ERR12/2H N,2HON,2H-N,2HUM,2HER,2HIC,2H I, 1 2HN ,2HRE,2HAL,2H O,2HR ,2HIN,2HTE,2HGE,2HR , 1 2HVA,2HLU,2HE / DATA ERR13/2H D,2HAT,2HA ,2HIT,2HEM,2H V,2HAL, 1 2HUE,2H T,2HOO,2H L,2HON,2HG / DATA ERR16/2H I,2HNV,2HAL,2HID,2H D,2HAT, & 2HA ,2HIT,2HEM,2H V,2HAL,2HUE,2H O,2HR , & 2HTE,2HRM,2HIN,2HAT,2HOR/ DATA ERR18/2H B,2HAD,2H D,2HAT,2HA ,2HSE,2HT / DATA ERR19/2H I,2HTE,2HM ,2HNO,2HT ,2HME,2HMB,2HER, & 2H O,2HF ,2HDA,2HTA,2H S,2HET,2H O,2HR ,2HDA,2HTA, & 2H S,2HET,2H N,2HOT,2H S,2HPE,2HCI,2HFI,2HED/ C CAN'T ACCESS AUTOMATIC MASTER DATA ERR20/2H C,2HAN,2H'T,2H A,2HCC,2HES,2HS ,2HAU,2HTO, & 2HMA,2HTI,2HC ,2HMA,2HST,2HER/ DATA NAME/2HNA,2HME/ DATA FIND/2HFI,2HND/ DATA X/130B/ DATA R/122B/ DATA D/104B/ DATA VALUE/2HWH,2HAT,2H I,2HS ,2HTH, 1 2HE ,2HVA,2HLU,2HE ,2HOF,2H _/ DATA IQSEC/6/ DATA MAXLN/255/ C C C C C C C C C C C C BEGIN C DO 1 J=1,50 DO 1 I=1,15 S(I,J) = 0 1 CONTINUE RRCNT = 0 IF(DBNAM.NE.2H ) GOTO 5 C ERROR DATA-BASE NOT DECLARED CALL ERIO(2,ITTY,ERR11,12) GOTO 10 5 CONTINUE C C GET SYSTEM TRACKS C C RELEASE ANY PREVIOUS QSKIB TRACKS C CALL EXEC(100005B,1,TRKNM,IDILU) I=I GOTO 6 C C GET A NEW TRACK FOR QSKIB C 6 CALL EXEC(4,1,TRKNM,IDILU,NSEC) NSEC=NSEC/2 IF (TRKNM.GE.0)GOTO15 C ERROR - NOT ANY TRACKS AVAILABLE FOR QSKIB CALL ERIO(2,ITTY,ERR1,14) C C EXIT FIND WITH ERROR C 10 CONTINUE SNAM(2)=2H CALL LOAD(SNAM) C C VERIFY THE SELECT FILE C 15 IF(SELECT.NE.2H ) GOTO 110 C ERROR - SELECT-FILE NOT DECLARED CALL ERIO(2,ITTY,ERR9,13) GO TO 10 C C C C BEGIN PROCESSING FIND COMMAND C C C FIND SETNM.ITEM "VALUE" END; C OR C FIND SETNM.ITEM "VALUE","VALUE" END; C OR C FIND SETNM.ITEM "VALUE" C ITEM "VALUE" END; C C C 110 CONTINUE IOFF=1 NOWSEC=0 R3 = 1 DSNUM = 0 IDISP = 1 C C C C C LOOP TO SET UP S-ARRAY C C C C 200 CONTINUE IF (R3.LE.50) GO TO 230 C ERROR - FIND PROCEDURE TOO LONG CALL ERIO(2,ITTY,ERR2,12) GO TO 10 230 CALL LSCAN(IB,I,J,K) I1 = I J1 = J C SYMBOL? IF (K.EQ.2) GO TO 280 C ERROR - ILLEGAL DATA ITEM NAME 250 DO 251 M=13,15 251 ERR3(M)=2H IF ((J1-I1+1).GT.6) J1=I1+5 CALL SMOVE(IB,I1,J1,ERR3,25) CALL ERIO (2,ITTY,ERR3,15) GO TO 10 C ERROR - RETRIEVAL FROM MORE THAN ONE DATA-SET 260 CALL ERIO(2,ITTY,ERR10,19) GO TO 10 C C ERROR - BAD SET C 265 CALL ERIO(2,ITTY,ERR18,7) GOTO 10 C C OUTPUT "ITEM NOT MEMBER OF DATA SET" C 267 CALL ERIO(2,ITTY,ERR19,27) GOTO 10 C C VERIFY VALID DATA-ITEM C 280 CALL SFILL(DINAM,1,6,40B) IF(J-I.GT.5) GOTO 250 CALL SMOVE(IB,I,J,DINAM,1) C CHECK FOR PROCEDURE C "NAME="? C SCAN FOR "=" C CALL LSCAN(IB,I,J,K) IF (R3.NE.1) GO TO 281 IF (J1-I1+1.NE.4) GO TO 281 IF (JSCOM(NAME,1,4,DINAM,1,IERR).NE.0) GO TO 281 IF (K .NE. 6) GOTO 281 C C GET THE PROCEDURE NAME C CALL GTPRC(FIND,4,IERR) IF(IERR .NE. 0) GOTO 10 IOFLAG = 1 GOTO 110 C C WAS A DATA SET GIVEN WITH THE ITEM? C 281 CONTINUE IF(K .NE. 7) GOTO 283 CALL DBINF(DBNAM,DINAM,201,ISTAT,IBUF) IF(ISTAT .NE. 0) GOTO 265 IBUF = IABS(IBUF) C C VERIFY THAT THIS DATA SET IS THE FIRST TO BE DEFINED, C OR ELSE MATCHES THE DATA SET ALREADY DEFINED C IF(DSNUM .EQ. 0) DSNUM = IBUF IF(DSNUM .NE. IBUF) GOTO 260 C C GET THE ITEM NAME C CALL LSCAN(IB,I,J,K) I1=I J1=J C COMMA? IF(K .NE. 2) GOTO 250 CALL SFILL(DINAM,1,6,40B) IF(J-I .GT. 5) GOTO 250 CALL SMOVE(IB,I,J,DINAM,1) CALL LSCAN(IB,I,J,K) C C GET THE ITEM'S NUMBER C 283 CONTINUE CALL DBINF(DBNAM,DINAM,101,ISTAT,IBUF) IF(ISTAT .NE. 0) GOTO 250 DINUM = IABS(IBUF) S(1,R3) = DINUM C C VERIFY ITEM BELONGS TO DECLARED SET C IF ( MEMBR(DBNAM,DSNUM,DINUM,ISTAT) .EQ. .FALSE. ) GOTO 267 C C GET ITEM'S CHARACTERISTICS C CALL DBINF(DBNAM,DINUM,102,ISTAT,IBUF) IF(ISTAT .NE. 0) GOTO 250 C C GET THE ITEM TYPE C CALL SGET(IBUF,17,ITYPE) S(8,R3) = ITYPE C C GET ITEM LENGTH C S(9,R3) = IBUF(10) S(15,R3) = IBUF(11) C C CALCULATE OFFSET INTO RECORD C IF(R3 .LE. 1) GOTO 35 DO 30 INDX = R3-1,1,-1 IF(S(1,INDX) .EQ. DINUM) GOTO 40 30 CONTINUE 35 CONTINUE S(10,R3) = IDISP INDX = IBUF(10) * IBUF(11) IF(ITYPE .EQ. X) INDX = INDX/2 IDISP = IDISP + INDX GOTO 45 C C OFFSET IS THE SAME AS THE EARLIER DECLARED ITEM C 40 S(10,R3) = S(10,INDX) C C SET PATH FLAG C 45 CONTINUE S(12,R3) = 1 IF(ISPTH(DBNAM,DSNUM,DINUM,ISTAT) .EQ. .FALSE.) S(12,R3) = 0 IF(ISTAT .NE. 0) GOTO 250 C C GET CAPACTY AND TYPE C CALL DBINF(DBNAM,DSNUM,202,ISTAT,IBUF) IF(ISTAT .NE. 0) GOTO 265 CALL SGET(IBUF,17,S(11,R3) ) S(13,R3) =IBUF(14) S(14,R3) = IBUF(15) C C DECODE RELATIONAL OPERATOR C 290 CONTINUE GO TO (291,292,293,294,295) (J-I+1) C C ERROR - RELATIONAL OPERATOR INVALID C 291 CALL ERIO(2,ITTY,ERR4,14) GO TO 10 292 S(2,R3)=1 IF(JSCOM(IB,I,J,IS,1,IERR).EQ.0) GO TO 300 IF(JSCOM(IB,I,J,IE,1,IERR).EQ.0) GO TO 300 GO TO 291 293 S(2,R3)=2 IF(JSCOM(IB,I,J,INE,1,IERR).EQ.0) GO TO 300 S (2,R3) = 3 IF(JSCOM(IB,I,J,ILT,1,IERR).EQ.0) GO TO 300 S(2,R3) = 5 IF(JSCOM(IB,I,J,IGT,1,IERR).EQ.0) GO TO 300 GO TO 291 294 S(2,R3)=4 IF(JSCOM(IB,I,J,INLT,1,IERR).EQ.0) GO TO 300 S(2,R3) = 6 IF(JSCOM(IB,I,J,INGT,1,IERR).EQ.0) GO TO 300 GO TO 291 295 S(2,R3)=2 IF (JSCOM(IB,I,J,INA,1,IERR).NE.0) GO TO 291 C GET DATA ITEM VALUE AND PUT IN QSKIB FILE C ENTER SECTOR AND WORD OFFSET OF VALUE 300 S(3,R3)=IOFF S(6,R3)=NOWSEC 350 CALL LSCAN(IB,I,J,K) IF (K.EQ.3) GO TO 400 C ERROR - ILLEGAL DATA ITEM VALUE OR TERMINATOR CALL ERIO(2,ITTY,ERR16,19) GO TO 10 400 LEN=J-I+1 IF (LEN.EQ.0) GO TO 405 C MOVE VALUE FOR CONVERSION IF (LEN.LE.MAXLN) GO TO 421 C DATA ITEM VALUE TOO LONG CALL ERIO(2,ITTY,ERR13,13) GO TO 10 421 CALL SMOVE(IB,I,J,BUFF,1) GO TO 410 C C REQUEST VALUE FORM USER C THE FOLLOWING CODE IS KLUDGED UP BECAUSE THE SUBROUTINES C INPUT AND LSCAN GET THEIR PARAMETERS FROM COMMON AND ARE C VERY INFLEXIBLE. SINCE INPUT READS INTO THE BUFFER IB C UNTIL IT REACHES THE CHARACTER LIMIT IBSZ, MODIFYING ISCAN C AND IEND, THE BUFFER IB, ISCAN, AND IEND MUST BE SAVED. C IBSZ WILL BE MODIFIED TO INDICATE THE LENGTH OF THE SECONDARY C BUFFER CALLED BUFF, SO IBSZ MUST ALSO BE SAVED. THERE IS NO C NEED TO ECHO THE INPUT BECAUSE THE INPUT IS NOT FROM A PROCEDURE C FILE, SO IPFLAG AND IOFLAG MUST BE SAVED THEN SET TO ZERO. C ALL THE PARAMETERS MUST BE RESTORED BEFORE CALLING THE SUBROUTINE C ERIO, BECAUSE ERIO RETURNS TO QS WHENEVER A BATCH FILE IS BEING C EXECUTED. C C C 405 CONTINUE CALL SFILL(BUFF,1,260,40B) CALL SMOVE(IB,1,260,SAVBF,1) SAVE(1) = IBSZ SAVE(2) = ISCAN SAVE(3) = IEND SAVE(4) = IPFLAG SAVE(5) = IOFLAG C C RESET IBSZ TO INDICATE THE SMALL BUFFER C IBSZ = 130 IPFLAG = 0 IOFLAG = 0 C C IF THIS IS BATCH SKIP THE PROMPT C IF(BATCH) GOTO 4052 CALL QRIO(2,INLU,VALUE,11) CALL QRIO(2,INLU,DINAM,3) C C GET THE INPUT C 4052 CONTINUE CALL INPUT CALL LSCAN(IB,I,J,K) LEN = 0 IF(K .EQ. 5) GOTO 4054 IF(K .EQ. 3) GOTO 4053 C C ERROR - RESTORE THE PARAMETERS C CALL SMOVE(SAVBF,1,260,IB,1) IBSZ = SAVE(1) ISCAN = SAVE(2) IEND = SAVE(3) IPFLAG = SAVE(4) IOFLAG = SAVE(5) C CALL ERIO(2,ITTY,ERR16,19) GOTO 405 C C PUT THE BUFFER INTO BUFF FOR PROCESSING C 4053 CONTINUE LEN = J-I+1 IF(LEN .EQ. 0) GOTO 4054 CALL SMOVE(IB,I,J,BUFF,1) C C RESTORE THE ORIGINAL INPUT BUFFER C 4054 CONTINUE CALL SMOVE(SAVBF,1,260,IB,1) IBSZ = SAVE(1) ISCAN = SAVE(2) IEND = SAVE(3) IPFLAG = SAVE(4) IOFLAG = SAVE(5) C C IF THE INPUT IS NULL THEN DEFAULT IT C IF (LEN.EQ.0) LEN = 1 C C FILL LAST BYTE WITH BLANK C 410 CALL SPUT(BUFF,(LEN+1),40B) C C CONVERT REAL OR INTEGER VALUE FORM ASCII C IF (ITYPE.EQ.X) GO TO 416 IF (ITYPE.EQ.R) GO TO 417 C CONVERT TO INTEGER CALL CATI(BUFF,1,LEN,INT,ISTAT) IF (ISTAT.EQ.0) GO TO 418 C NON-NUMERIC IN REAL OR INTEGER VALUE 419 CALL ERIO (2,ITTY,ERR12,19) GO TO 10 418 CONTINUE BUFF(1)=INT LEN=2 GO TO 416 C CONVERT TO REAL 417 REAL=CATR(BUFF,1,LEN,ISTAT) IF (ISTAT.NE.0) GO TO 419 CALL SMOVE (REAL,1,4,BUFF,1) LEN=4 C ENTER VALUE 416 LENFLG=0 C LENGTH IN WORDS LEN=(LEN+1)/2 DO 411 MOVE=0,LEN IF (LENFLG.EQ.1) GO TO 414 IBUFF(IOFF)=LEN LENFLG=1 GO TO 415 414 IBUFF(IOFF)=BUFF(MOVE) 415 IOFF=IOFF+1 IF (IOFF.LE.IBSZ) GO TO 411 C BUFFER FULL - WRITE TO QSKIB IF ((NOWSEC+IQSEC).LE.NSEC) GO TO 412 C NOT ENOUGH SECTORS IN QSKIB 413 CALL ERIO(2,ITTY,ERR8,14) GO TO 10 412 CALL EXEC (2,IDILU,IBUFF,IBSZ,TRKNM,NOWSEC) NOWSEC=NOWSEC+IQSEC IOFF=1 411 CONTINUE S(4,R3)=S(4,R3)+1 S(7,R3)=S(7,R3)+1 IF (S(2,R3).LT.3) GO TO 620 IF (S(4,R3).EQ.1) GO TO 620 C ERROR - INVALID # OF VALUES FOR RELATIONAL OPERATOR CALL ERIO(2,ITTY,ERR6,22) GO TO 10 C C C C ERROR - INVALID LOGICAL CONNECTOR C 610 DO 611 M=14,16 611 ERR7(M)=2H M=J IF((M-I+1).GT.6) M=I+5 CALL SMOVE(IB,I,M,ERR7,27) C C ERROR - ILLEGAL DATA ITEM VALUE OR TERMINATOR C CALL ERIO(2,ITTY,ERR7,16) GO TO 10 C C C 620 CONTINUE CALL LSCAN (IB,I,J,K) IF (K.EQ.4) GO TO 350 IF (K.EQ.2) GO TO 500 C ERROR - ILLEGAL DATA ITEM VALUE OR TERMINATOR CALL ERIO (2,ITTY,ERR16,19) GO TO 10 C C IS THIS AN "AND" CONNECTOR? C 500 IF (J-I+1.NE.3) GO TO 640 IF (JSCOM(IB,I,J,AND,1,IERR).NE.0) GO TO 650 S(5,R3) = 1 630 R3 = R3 + 1 GO TO 200 C C IS THIS AN "OR" CONNECTOR C 640 IF (J-I+1.NE.2) GO TO 610 IF (JSCOM(IB,I,J,OR,1,IERR).NE.0) GO TO 610 S(5,R3) = 2 GO TO 630 C C IS THIS AN "END" STATEMENT C 650 IF(JSCOM(IB,I,J,END,1,IERR).NE.0) GO TO 610 CALL LSCAN(IB,I,J,K) IF(K .NE. 5) GOTO 610 S(5,R3) = 3 C C MOVE VALUES ARRAY, IBUFF, TO BUFF C DO 720 J=1,(IOFF-1) IMA(J)=IBUFF(J) 720 CONTINUE C C C IF (NOWSEC.EQ.0) GO TO 750 C WRITE LAST SECTORS TO QSKIB FILE IF ((NOWSEC+IQSEC).GT.NSEC) GO TO 413 CALL EXEC (2,IDILU,IBUFF,IBSZ,TRKNM,NOWSEC) C SAVE CURRENT SECTOR NUMBER OF QSKIB 750 SECNO =NOWSEC C C CALL SEARCH TO RETRIEVE RECORDS C SNAM(2) = 2H01 CALL LOAD(SNAM) END $