FTN4
      PROGRAM QY07(5,90),92069-16060 REV.2026 800122
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-18070
C     RELOC:     92069-16060
C 
C     ALTERED:   JANUARY 22, 1980 FOR SORTED CHAINS FEATURE - CEJ 
C 
C************************************************************ 
C 
C 
C  UPDATE SERVICE MODULE (PART I) 
C  HAS BEEN SPLIT INTO TWO (2) MODULES
C  IN ORDER TO FIT INTO 16K MEMORY
C 
C  QS07 CONTAINS THE OPERATOR INTERFACE 
C  QS14 CONTAINS THE REPLACE, ADD, AND DELETE ROUTINES
C 
      LOGICAL ISPTH 
      LOGICAL ISSRT 
      LOGICAL MEMBR 
      INTEGER ERR1(7) 
      INTEGER ERR2(14)
      INTEGER ERR4(15)
      INTEGER ERR5(12)
      INTEGER ERR7(14)
      INTEGER ERR8(13)
      INTEGER ERR9(14)
      INTEGER ERR10(14) 
      INTEGER ERR11(16) 
      INTEGER PRMPT(3)
      INTEGER REPLC(4),ADD(4),DELT(4) 
      INTEGER NAME(2) 
      INTEGER A,R,D 
      INTEGER INFO(13)
      INTEGER ITEMS(128)
      INTEGER INBR(128) 
      INTEGER ASK(5)
      INTEGER DZERO(2)
      INTEGER P2,ELCNT
      INTEGER ISTAT(10) 
      INTEGER IMODE(4)
      INTEGER UPDATE(3) 
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(S(1,1),ICHAR) 
      EQUIVALENCE(S(3,1),INBR)
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
      DATA DZERO/0,0/ 
      DATA ASK/2H  ,2H  ,2H  ,2H =,2H _/
      DATA NAME/2HNA,2HME/
C     SYNTAX ERROR
      DATA ERR1/2H S,2HYN,2HTA,2HX ,2HER,2HRO,2HR / 
C ILLEGAL ACCESS TO DATA SET
      DATA ERR2/2H I,2HLL,2HEG,2HAL,
     & 2H A,2HCC,2HES,2HS ,2HTO,2H D,2HAT,2HA ,2HSE,2HT / 
C  RECORD NOT YET BEEN FOUND
      DATA ERR4/2H R,2HEC,2HOR,2HD ,2HNO,2HT ,
     & 2HYE,2HT ,2HBE,2HEN,2H F,2HOU,2HND/
C ILLEGAL DATA ITEM NAME
      DATA ERR5/2H I,2HLL,2HEG,2HAL,2H D,2HAT,2HA , 
     & 2HIT,2HEM,2H N,2HAM,2HE /
C MUST ENTER PATH ITEM VALUE
      DATA ERR7/2H M,2HUS,2HT ,2HEN,2HTE,2HR ,
     &2HPA,2HTH,2H I,2HTE,2HM ,2HVA,2HLU,2HE /
      DATA ERR8/2H I,2HLL,2HEG,2HAL,2H P,2HAT,2HH ,2HMO,2HDI,2HFI,
     &2HCA,2HTI,2HON/ 
C USER ACCESS NOT HIGH ENOUGH 
      DATA ERR9/2H U,2HSE,2HR ,2HAC,2HCE,2HSS,2H N,2HOT,2H H, 
     &  2HIG,2HH ,2HEN,2HOU,2HGH/ 
C MUST ENTER SORT ITEM VALUE
      DATA ERR10/2H M,2HUS,2HT ,2HEN,2HTE,2HR ,2HSO,2HRT, 
     &  2H I,2HTE,2HM ,2HVA,2HLU,2HE /
C ILLEGAL SORT ITEM MODIFICATION
      DATA ERR11/2H I,2HLL,2HEG,2HAL,2H S,2HOR,2HT ,2HVA, 
     &  2HLU,2HE ,2HMO,2HDI,2HFI,2HCA,2HTI,2HON/
      DATA PRMPT/2H I,2HTE,2HM_/
      DATA A/101B/
      DATA D/104B/
      DATA R/122B/
      DATA INTGR/111B/
      DATA REPLC/2HRE,2HPL,2HAC,2HE / 
      DATA ADD/2HAD,2HD ,2H  ,2H  / 
      DATA DELT/2HDE,2HLE,2HTE,2H  /
C     UPDATE
C 
C 
      DATA UPDATE/2HUP,2HDA,2HTE/ 
C 
C 
C 
C 
C 
C  UPDATE NAME = <PROCEDURE NAME>;
C         A[DD],<DATA SET NAME>;
C 
C         QUERY PROMPTS THE USER WITH EACH ITEM NAME TO 
C         WHICH HE HAS ACCESS. THE USER MAY ENTER A VALUE 
C         OR A SEMICOLN.  WHEN A SEMICOLN IS ENTER QUERY
C         PUTS A NULL VALUE IN THE DATA RECORD.  QUERY PROHIBITS
C         NULL VALUES FOR PATH ITEMS.  A USER CAN TERMINATE THE 
C         UPDATE WITH THE BR[EAK] COMMAND.
C 
C         D[ELETE]; 
C 
C         R[EPLACE];
C         <DATA ITEM NAME> = "<VALUE>" [,"<VALUE>","<VALUE>"] ; 
C              WHERE ARRAY VALUES ARE ENTERED IN AS A LIST OF 
C                    VALUES SEPARATED BY COMMAS AND TERMINATED
C                    BY A SEMICOLN.  WHEN TWO COMMAS ARE ENTERED
C                    ADJACENT A NULL VALUE IS ENTERED FOR THAT
C                    ELEMENT. 
C 
C 
C 
C 
C 
C BEGIN 
C 
C 
      INBR = 0
      P2 = 1
C 
C  CHECK FOR PROCEDURE
C 
      CALL LSCAN(IB,I,J,K)
      IF(K .NE. 2) GOTO 50
      IF(J-I.NE.3) GOTO 30
      IF(JSCOM(NAME,1,4,IB,I,IERR).NE.0) GOTO 30
C  SCAN ACROSS =
      CALL LSCAN(IB,I,J,K)
      IF(K.NE.6) GOTO 50
C 
C  GET PROCEDURE NAME 
C 
      CALL GTPRC(UPDATE,6,IERR) 
      IF(IERR .NE. 0) GOTO 70 
      IOFLAG = 1
C 
C GET UPDATE TYPE 
C 
      CALL LSCAN(IB,I,J,K)
      IF(K .NE. 2) GOTO 50
C 
C VERIFY THAT THE UPDATE TYPE IS LEGAL
C 
30    CALL SGET(IB,I,ICHAR) 
      IF(J-I+1 .NE. 1) GOTO 40
C 
C  A = UPDATE ADD 
C  D = UPDATE DELETE
C  R = UPDATE REPLACE 
C 
      IF(ICHAR.EQ.A) GOTO 110 
      IF(ICHAR.EQ.D) GOTO 610 
      IF(ICHAR.EQ.R) GOTO 500 
      GOTO 50 
C 
C ADD = UPDATE ADD
C DELETE = UPDATE DELETE
C REPLACE = UPDATE REPLACE
C 
40    CONTINUE
      IF(J-I+1 .GT. 8) GOTO 50
      CALL SFILL(IMODE,1,8,40B) 
      CALL SMOVE(IB,I,J,IMODE,1)
      IF(JSCOM(IMODE,1,8,ADD,1) .EQ. 0) GOTO 110
      IF(JSCOM(IMODE,1,8,REPLC,1) .EQ. 0) GOTO 500
      IF(JSCOM(IMODE,1,8,DELT,1) .EQ. 0) GOTO 610 
C 
C  ERROR - SYNTAX ERROR 
C 
50    CONTINUE
      IP = 1
54    IF(IEND .LE. 72) GOTO 57
      CALL QRIO(2,ITTY,IB(IP),-72)
      IEND = IEND - 72
      IP = IP + 36
      GOTO 54 
C 
C WRITE LAST LINE OUT 
C 
57    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,ERR1,7)
C 
C  RETURN TO NEXT?
C 
70    SNAM(2) = 2H
      GOTO 100
C 
C  ERROR - DBMS 
C 
80    QSERR = ISTAT 
      SNAM(2) = 2H23
      GOTO 100
C 
C  LOAD MODULE QS14 FOR REPLACE,ADD, AND DELETE UPDATES 
C 
90    SNAM(2) = 2H14
100   CALL LOAD(SNAM) 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C  ADD STATEMENT
C 
C  SCAN ACROSS ","
C 
110   CONTINUE
      CALL LSCAN(IB,I,J,K)
      IF(K.NE.4) GOTO 50
      CALL LSCAN(IB,I,J,K)
C 
C  GET DATA SET NAME
C 
      IF(J-I.GT.5) GOTO 50
      CALL SFILL(DSNAM,1,6,40B) 
      CALL SMOVE(IB,I,J,DSNAM,1)
C 
C  VERIFY THE SEMICOLN
C 
      CALL LSCAN(IB,I,J,K)
      IF(K .NE. 5) GOTO 50
C 
C  VERIFY DATA SET NAME 
C 
      CALL DBINF(DBNAM,DSNAM,201,ISTAT,INFO)
      IF(ISTAT .NE. 0) GOTO 80
      IF(INFO .LT. 0) GOTO 130
C 
C  ERROR - ILLEGAL ACCESS TO DATA SET 
C 
120   CONTINUE
      CALL ERIO(2,ITTY,ERR2,14) 
      GOTO 70 
C 
C GET THE DATA SET NUMBER 
C 
130   DSNUM = -INFO 
      IPFLAG = 0
      IOFLAG = 0
C 
C  GET ALL DATA ITEM #S FOR THIS SET
C 
      CALL DBINF(DBNAM,DSNUM,104,ISTAT,ITEMS) 
      IF(ISTAT .NE. 0) GOTO 80
      IF(ITEMS .EQ. 0) GOTO 120 
C 
C  LOOP ON ITEM COUNT AND GET VALUE 
C 
140   CONTINUE
      DO 320 LOOP=2,ITEMS+1 
C 
C IF NO READ/WRITE ACCESS THEN SKIP ITEM
C 
      IF(ITEMS(LOOP) .GE. 0) GOTO 320 
      DINUM = -ITEMS(LOOP)
C 
C  GET ITEM CHARACTERISTICS 
C 
      CALL DBINF(DBNAM,DINUM,102,ISTAT,INFO)
      IF(ISTAT .NE. 0) GOTO 80
      CALL SGET(INFO,17,ITYPE)
      LEN = INFO(10)
      IF(ITYPE .EQ. R  .OR. ITYPE .EQ. INTGR) LEN = LEN * 2 
      ELCNT =  INFO(11) 
C 
C GET VALUE FROM USER 
C 
      CALL SMOVE(INFO,1,6,ASK,3)
160   IF(.NOT. BATCH) CALL QRIO(2,INLU,ASK(1),5)
C 
C SEE IF BREAK WAS REQUESTED
C 
      CALL INPUT
      IF (BREAK) GOTO 70
C 
C 
C SEE IF ONLY A SEMICOLN WAS ENTERED
C  NOTE:  LSCAN MUST NOT BE USED HERE BECAUSE 
C         GETVL EXPECTS TO TO THE CALL TO LSCAN 
C 
      DO 165 I = ISCAN,IEND 
      CALL SGET(IB,I,ITERM) 
      IF( ITERM .EQ. 40B) GOTO 165
      IF(ITERM .NE. 73B) 180,167
165   CONTINUE
C 
C IF THIS IS A PATH - A VALUE MUST BE ENTERED 
C 
167   CONTINUE
      IF(.NOT. ISPTH(DBNAM,DSNUM,DINUM,ISTAT) ) GOTO 170
      CALL ERIO(2,ITTY,ERR7,14) 
      GOTO 182
C 
C BE SURE THERE WERE NO DBMS ERRORS 
C 
170   CONTINUE
      IF(ISTAT) 80,175,80 
C 
C IF THIS IS A SORT ITEM - A VALUE MUST BE INTERED
C 
175   CONTINUE
      IF (.NOT. ISSRT(DBNAM,DSNUM,DINUM,ISTAT)) GOTO 178
      CALL ERIO(2,ITTY,ERR10,14)
      GOTO 182
C 
C BE SURE THERE WERE NO DBMS ERRORS 
C 
178   CONTINUE
      IF (ISTAT) 80,180,80
C 
C  PUT THE ITEM VALUE INTO THE DATA BUFFER
C 
180   CONTINUE
      CALL GETVL(DSNUM,DINUM,ITYPE,LEN,ELCNT,IBUFF,P2,IB,ITTY,IERR) 
      IF(IERR .EQ. 0) GOTO 185
C 
C IF THIS IS A BATCH FILE TERMINATE ELSE GO ASK AGAIN 
C 
182   CONTINUE
      IF(BATCH) 70,160
C 
C PUT ITEM IN PUT LIST
C 
185   CONTINUE
C 
C LEAVE ENOUGH ROOM FOR ALL THE ELEMENTS
C 
      P2 = LEN * ELCNT + P2 
      INBR = INBR + 1 
      INBR(INBR+1) = DINUM
C 
C BE SURE THAT AN ITEM IS TO BE ADDED 
C 
320   CONTINUE
      IF(INBR .EQ. 0) GOTO 120
      SNAM(2) = 2H22
      GOTO 100
C 
C 
C 
C 
C 
C 
C 
C 
C  REPLACE STATEMENT
C 
C 
C 
C 
C 
C VERIFY SEMICOLN 
C 
500   CONTINUE
      CALL LSCAN(IB,I,J,K)
      IF(K .NE. 5) GOTO 50
C 
C VERIFY THAT THE SELECT FILE IS NOT EMPTY
C 
      IF(DCO(RRCNT,DZERO) )505,505,510
505   CALL ERIO(2,ITTY,ERR4,13) 
      GOTO 70 
C 
C GET THE INPUT FROM THE USER 
C IF THIS IS A PROCEDURE FILE GET THE INPUT 
C FROM THE PROCEDURE. 
C 
510   CONTINUE
      IF((IPFLAG .EQ. 0).AND.(.NOT. BATCH)) CALL QRIO(2,INLU,PRMPT,3) 
C 
C GET THE ITEM NAME 
C 
      CALL LSCAN(IB,I,J,K)
      IF(BREAK) GOTO 70 
C 
C A SEMICOLN INSTEAD OF AN ITEM NAME TERMINATES THE INPUT 
C 
      IF(K .EQ. 5) GOTO 90
C 
C VERIFY LEGAL NAME 
C 
      IF(K .NE. 2) GOTO 530 
      IF(J-I.GT.5) GOTO 530 
      CALL SFILL(DINAM,1,6,40B) 
C 
      CALL SMOVE(IB,I,J,DINAM,1)
C 
C GET THE "=" FROM THE INPUT LINE 
C 
      CALL LSCAN(IB,I,J,K)
      IF(K .EQ. 6) GOTO 520 
C 
C  GET DATA ITEM NUMBER 
C 
520   CONTINUE
      CALL DBINF(DBNAM,DINAM,101,ISTAT,INFO)
      IF(ISTAT .EQ. 0) GOTO 540 
C 
C  ERROR - ILLEGAL DATA ITEM NAME 
C 
530   CONTINUE
      CALL ERIO(2,ITTY,ERR5,12) 
      GOTO 590
C 
C VERIFY THAT A PATH IS NOT BEING CHANGED 
C 
540   CONTINUE
      IF(INFO .LT. 0) GOTO 541
      CALL ERIO(2,ITTY,ERR9,14) 
      GOTO 590
C 
C 
C 
541   CONTINUE
      DINUM = -INFO 
      IF( .NOT. ISPTH(DBNAM,DSNUM,DINUM,ISTAT) ) GOTO 542 
      CALL ERIO(2,ITTY,ERR8,13) 
      GOTO 590
C 
C VERIFY THAT A SORT VALUE IS NOT BEING CHANGED 
C 
542   CONTINUE
      IF (ISTAT .NE. 0) GOTO 530
      IF (.NOT. ISSRT(DBNAM,DSNUM,DINUM,ISTAT)) GOTO 543
      CALL ERIO(2,ITTY,ERR11,16)
      GOTO 590
C 
C MAKE SURE NO DBMS ERROR OCCURRED
C 
543   CONTINUE
      IF (ISTAT .NE. 0) GOTO 530
C 
C VERIFY THIS IS A MEMBER OF THE DECLARED DATA SET
C 
545   CONTINUE
      IF(MEMBR(DBNAM,DSNUM,DINUM,ISTAT)) GOTO 550 
      CALL ERIO(2,ITTY,ERR5,12) 
      GOTO 590
C 
C  GET DATA ITEM CHARACTERISTICS
C 
550   CONTINUE
      CALL DBINF(DBNAM,DINUM,102,ISTAT,INFO)
      IF(ISTAT .NE. 0) GOTO 530 
C 
C GET THE ITEM TYPE, LENGTH, AND ELEMENT COUNT
C 
      CALL SGET (INFO,17,ITYPE) 
      LEN = INFO(10)
      IF((ITYPE .EQ. R) .OR. (ITYPE .EQ. INTGR)) LEN = LEN*2
      ELCNT = INFO(11)
C 
C GET THE VALUE FROM THE USER 
C 
      CALL GETVL(DSNUM,DINUM,ITYPE,LEN,ELCNT,IBUFF,P2,IB,ITTY,IERR) 
      IF(IERR .NE. 0) GOTO 590
C 
C VERIFY INPUT STRING ENDED WITH A SEMICOLN 
C 
C 
C PUT ITEM IN LIST
C 
560   CONTINUE
      P2 = P2 + LEN * ELCNT 
      INBR = INBR + 1 
      INBR(INBR+1) = DINUM
580   CONTINUE
      GOTO 510
C 
C 
C 
C 
C 
C REPLACE ERROR PROCESSOR 
C 
590   CONTINUE
      IF((BATCH) .OR. (IPFLAG .NE. 0)) GOTO 70
C 
C SCAN FOR SEMICOLN 
C 
595   CONTINUE
      CALL LSCAN(IB,I,J,K)
      IF(K .NE. 5) GOTO 595 
      GOTO 510
C 
C 
C 
C 
C 
C 
C 
C DELETE RECORD 
C 
C 
C 
C 
C 
610   CONTINUE
      IF(DCO(RRCNT,DZERO) )630,620,630
620   CALL ERIO(2,ITTY,ERR4,13) 
      GOTO 70 
C 
C BE SURE THIS SET HAS DELETE ACCESS
C 
630   CONTINUE
      CALL DBINF(DBNAM,DSNUM,201,ISTAT,INFO)
      IF(ISTAT .NE. 0) GOTO 80
      IF( INFO .LT.0) GOTO 90 
      CALL ERIO(2,ITTY,ERR9,14) 
      GOTO 70 
      END