FTN 
      PROGRAM LEVL2(5,90),92069-16015 REV.2026 800124 
C 
C 
C*****************************************************************
C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED 
C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR
C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR
C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. 
C****************************************************************** 
C 
C 
C     SOURCE:    92069-18020
C     RELOC:     92069-16015
C 
C 
C****************************************************************:
C 
C 
C 
C         LEVEL SEGEMENT
C 
C 
C 
C ABSTRACT: 
C 
C LEVEL PROCESSES THE "LEVELS:" COMMAND. ALL THE NAMES OF THE LEVELS
C ARE PUT INTO THE DATA BASE CONTROL BLOCK.  THE LEVEL NUMBERS MUST 
C RANGE FROM 1 TO 15 INCLUSIVE.  ALL LEVEL NAMES MUST BE UNIQUE TO
C EACH OTHER.  LEVELS MAY BE DEFINED IN ANY ORDER, THAT IS LEVEL
C FIFTEEN MAY BE DEFINED BEFORE LEVEL TEN. LEVEL FIFTEEN NEED NOT 
C BE DEFINED AS IT WAS IN THE PREVIOUS DBDS.
C 
C COMMAND FORMAT: 
C 
C     LEVELS:  <LEVEL LIST>;
C 
C        WHERE: 
C 
C           LEVEL LIST
C           IS A LIST OF LEVEL DEFINITIONS SEPARATED BY ";" 
C 
C 
C 
C 
      INTEGER ITEM(3) 
C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ JANUARY 23,1980
C 
C 
C                      CONSTANTS IN INTEGER 
C 
C 
C 
      INTEGER AUTO,BADC,BASE,BEGIN,BLANK,BLKCD, 
     1       CAP,CNTRL,COLON,COMMA,CRDLM, 
     2       DATA,DETAIL,DOLLR,DOT, 
     3       ELSE,END,ENTY,EQUAL,ERR, 
     4       FIELD, 
     5       ICODE,INTGR,ITM, 
     6       LEVL,LPARN,LST,
     7       MANU,MXCAP,MAXRC,
     8       MXELE,MXENT,MXITM,MXLEV,MXSTR, 
     9       NAM,RSRV,ASET,AUSET,MSET,MASET,DSET,DESET,NM,NFONX,NFO,
     C       NOLST,NORES,NOTAB, 
     1       OPSET, 
     2       PMAX,
     3       ROOTR,RPARN, 
     4       SEMI,SET,SMAX, 
     5       UPPER
C 
C 
C 
C 
C                      DATA BASE OFFSETS
C 
C 
C 
      INTEGER DBNAM,DBSCD,DBCRN,DBDSN,DBRSN,DBICT,DBITP,
     1       DBSCT,DBSTP,DBSOP,DBFRP,DBLMD,DBLVL, 
     2       DBLVE
C 
C 
C 
C                     ITEM TABLE OFFSETS
C 
C 
C 
      INTEGER ITNME,ITINF,ITTYP,ITSCT,
     1       ITSNO,ITECT,ITLNG,ITMSZ,ITMST
C 
C 
C                     DATA SET TABLE OFFSETS
C 
C 
      INTEGER DSNME,DSCRN,DSTYP,DSMDL,DSDRL,DSFCT,DSPCT,
     1       DSITP,DSCAP,DSCCT,DSPAN,SETSZ
C 
C 
C 
C               OFFSET TO OVERHEAD RECORD 
C 
C 
C 
      INTEGER OVRRC,OVRTL,OVFRL,OVDCB,OVREC 
C 
C 
C 
C              ERROR MESSAGES 
C 
C 
      INTEGER ILCTR,ILCRN,ILSEC,XBEGN,XLEV, 
     1       DUPIT,ITLIM,ILITP,FLDER,ILXTP, 
     2       ILWR,ILTRM,NAMX,DUPST,STLIM, 
     3       ENTYX,NOITM,BDSET,BDKEY,DUPHS, 
     4       NOPTH,AERR,RCLIM,CAPX,ILCAP, 
     5       EMPTY,MXERR,EOF,NOSEG,NOMEM, 
     6       DUPLV,ILNAM,ILNMR,LVDEF,ILSEP, 
     7       ILRD,ILRNG,SETX,IGNSC,INMX,
     8       PTDUP,DBKEY,ENDX,PDEFC,SIMPT,
     9       BDCNT,RTERR,GOODS,GOODR,BADS,
     C       BADR,ABORT,OPNER,XCNTR,ILLVN,
     1       SRCH2,UEND,XITM,ELERR,ROTER, 
     2       UNITM,IOAIN,IOAOT,UNRDL,UNWRL,IOERR,ILOPT, 
     3       ILLSC,MORIT,ILPTH,DEFIT, 
     4       ILSRT,SIMPS,UNDST
C 
C 
C                 VARIABLES 
C 
C 
C 
      INTEGER CARD,CHAR,CODE,CRDPR
      REAL CPACK
      INTEGER DSEC,DCRN 
      INTEGER ENTL,ERROR
      LOGICAL NMFLG 
      INTEGER FWAM
      INTEGER GGERR 
      INTEGER ICNT,IDCB,INDX
      INTEGER INFPT,INFO,IGLOB,INPUT,ITMTB
      INTEGER KPACK 
      INTEGER LDCB,LGLOB,LIST,LWAM
      INTEGER MEDIA 
      INTEGER NPACK,NSETS 
      INTEGER OVRHD 
      INTEGER PTHTB 
      INTEGER RDEF,RESNO,RFILE,RINDX
      INTEGER SCNT,SETTB,SINDX,SORTI,SORTS,STYPE
      INTEGER TYPE,PRGFLG 
C 
C 
C    EXTERNAL REFERENCES
C 
C 
      INTEGER ROOTA 
C 
C                      CONSTANTS IN COMMON
C 
C 
C 
      COMMON/CONST/ AUTO,BADC,BASE,BEGIN,BLANK,BLKCD, 
     1       CAP,CNTRL,COLON,COMMA,CRDLM, 
     2       DATA,DETAIL,DOLLR,DOT, 
     3       ELSE,END,ENTY,EQUAL,ERR, 
     4       FIELD, 
     5       ICODE,INTGR,ITM, 
     6       LEVL,LPARN,LST,
     7       MANU,MXCAP(2),MAXRC, 
     8       MXELE,MXENT,MXITM,MXLEV,MXSTR, 
     9       NAM,RSRV,ASET,AUSET,MSET,MASET,DSET,DESET,NM,NFONX(10),
     C       NFO(10), 
     C       NOLST,NORES,NOTAB, 
     1       OPSET, 
     2       PMAX,
     3       ROOTR,RPARN, 
     4       SEMI,SET,SMAX, 
     5       UPPER
C 
C 
C 
C 
C                      DATA BASE OFFSETS
C 
C 
C 
      COMMON/DBCB/ DBNAM,DBSCD,DBCRN,DBDSN,DBRSN,DBICT,DBITP, 
     1       DBSCT,DBSTP,DBSOP,DBFRP,DBLMD,DBLVL, 
     2       DBLVE
C 
C 
C 
C                     ITEM TABLE OFFSETS
C 
C 
C 
      COMMON/ITCB/ ITNME,ITINF,ITTYP,ITSCT, 
     1       ITSNO,ITECT,ITLNG,ITMSZ,ITMST
C 
C 
C                     DATA SET TABLE OFFSETS
C 
C 
      COMMON/DSCB/ DSNME,DSCRN,DSTYP,DSMDL,DSDRL,DSFCT,DSPCT, 
     1       DSITP,DSCAP,DSCCT,DSPAN,SETSZ
C 
C 
C 
C               OFFSET TO OVERHEAD RECORD 
C 
C 
C 
      COMMON /OVCB/OVRRC,OVRTL,OVFRL,OVDCB,OVREC
C 
C 
C 
C              ERROR MESSAGES 
C 
C 
      COMMON/ERRM/ ILCTR,ILCRN,ILSEC,XBEGN,XLEV,
     1       DUPIT,ITLIM,ILITP,FLDER,ILXTP, 
     2       ILWR,ILTRM,NAMX,DUPST,STLIM, 
     3       ENTYX,NOITM,BDSET,BDKEY,DUPHS, 
     4       NOPTH,AERR,RCLIM,CAPX,ILCAP, 
     5       EMPTY,MXERR,EOF,NOSEG,NOMEM, 
     6       DUPLV,ILNAM,ILNMR,LVDEF,ILSEP, 
     7       ILRD,ILRNG,SETX,IGNSC,INMX,
     8       PTDUP,DBKEY,ENDX,PDEFC,SIMPT,
     9       BDCNT,RTERR,GOODS,GOODR,BADS,
     C       BADR,ABORT,OPNER,XCNTR,ILLVN,
     1       SRCH2,UEND,XITM,ELERR,ROTER, 
     2       UNITM,IOAIN,IOAOT,UNRDL,UNWRL,IOERR,ILOPT, 
     3       ILLSC,MORIT,ILPTH,DEFIT, 
     4       ILSRT,SIMPS,UNDST
C 
C 
C                 VARIABLES 
C 
C 
C 
      COMMON// CARD(36),CHAR,CODE,CPACK(50),CRDPR 
      COMMON DSEC,DCRN
      COMMON ENTL,ERROR 
      COMMON NMFLG
      COMMON FWAM 
      COMMON GGERR
      COMMON ICNT,IDCB(144),INDX
      COMMON INFPT,INFO(6),IGLOB(10),INPUT,ITMTB
      COMMON KPACK(50)
      COMMON LDCB(144),LGLOB,LIST,LWAM
      COMMON MEDIA
      COMMON NPACK(50),NSETS(50)
      COMMON OVRHD
      COMMON PTHTB(32)
      COMMON RDEF(64),RESNO,RFILE(3),RINDX
      COMMON SCNT,SETTB,SINDX,SORTI(255),SORTS(50),STYPE
      COMMON TYPE,PRGFLG
C 
C 
C    EXTERNAL REFERENCES
C 
C 
      EXTERNAL ROOTA
C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ JANUARY 23,1980
C CHANGED COMMON TO ADD ILSRT,SIMPS,UNDST AND INCREASE SIZE OF PTHTB
      DATA ITEM/2HIT,2HEM,2H2 / 
C 
C 
C 
C 
C BLANK THE LEVEL WORDS 
C 
      DO 5 I=DBLVL,DBLVE,2
      CALL SROOT(I,BLANK) 
5     CONTINUE
C 
C SET LEVEL FLAG TO INDICATE THAT NONE ARE PRESENT
C 
      CALL SROOT(DBLMD,-1)
C 
C VERIFY THAT THIS IS A LEVEL COMMAND 
C 
      IF(RESNO .NE. LEVL) GOTO 7030 
C 
C PROCESS THE LEVEL DEFINITIONS 
C 
      CALL GGLOB
C 
C WHILE NOT( SEMICOLON OR ITEM:)
C 
10    CONTINUE
      IF(TYPE .EQ. SEMI) GOTO 80
      IF(RESNO .EQ. ITM) GOTO 90
C 
C GET THE LEVEL NUMBER
C 
      IF ((TYPE .NE. INTGR) .OR. (IGLOB .LT. 1) .OR. (IGLOB .GT. 15)) 
     1    GOTO 7010 
C 
C GET INDEX INTO LEVEL WORD IN ROOT 
C 
      INDX = (IGLOB-1) * 6 + DBLVL
C 
C GET LEVEL NAME
C 
20    CONTINUE
      NMFLG = .TRUE.
      CALL GGLOB
      NMFLG = .FALSE. 
      IF (TYPE .NE. NAM) GOTO 7020
C 
C SEARCH FOR DUPLICATE ITEM NAME
C 
      DO 40 I=DBLVL,DBLVE,6 
      LNDX = I
        DO 30 I2=1,3
        IF(IGLOB(I2) .NE. ROOTA(LNDX)) GOTO 40
        LNDX = LNDX + 2 
30      CONTINUE
C 
C DUPLICATE NAME FOUND
C 
      GOTO 7040 
40    CONTINUE
C 
C CHECK THAT THIS LEVEL IS NOT ALREADY SPECIFIED
C 
      IF ( ROOTA(INDX) .NE. BLANK) GOTO 7050
C 
C PUT LEVEL NAME IN ROOT
C 
      DO 50 I=1,3 
      CALL SROOT(INDX,IGLOB(I) )
      INDX = INDX + 2 
50    CONTINUE
C 
C SET LEVEL FLAG TO INDICATE THAT THERE IS A LEVEL WORD 
C 
      CALL SROOT(DBLMD,0) 
C 
C 
C VERIFY SEMI-COMMA 
C 
55    CONTINUE
      CALL GGLOB
      IF(TYPE .NE. SEMI) CALL EMESS(ILTRM)
60    CONTINUE
      CALL SCAN(SEMI) 
      GOTO 10 
C 
C 
C 
C 
C SCAN PAST SEMICOLON 
C 
80    CONTINUE
      CALL SCAN(SEMI) 
C 
C LOAD AND EXECUTE ITEM PROCESSOR 
C 
90    CONTINUE
      CALL SEGLD(ITEM,IERR) 
C 
C IF SEGLD RETURNS THEN ERROR 
C 
      CALL OUTLN(ITEM,2)
      CALL ERXIT(NOSEG) 
C 
C 
C 
C ERROR PROCESSORS
C 
C OUTPUT "LEVEL OUT OF RANGE" 
C 
7010  CALL EMESS(ILRNG) 
      GOTO 60 
C 
C OUTPUT "ILLEGAL LEVEL WORD" 
C 
7020  CALL EMESS(ILLVN) 
      GOTO 60 
C 
C OUTPUT "LEVEL: EXPECTED"
C 
7030  CALL EMESS(XLEV)
      IF (RESNO .EQ. ITM) GOTO 90 
      CALL SCAN (SEMI)
      GOTO 90 
C 
C OUTPUT "DUPLICATE LEVEL WORD" 
C 
7040  CALL EMESS(DUPLV) 
      GOTO 55 
C 
C OUTPUT "LEVEL NUMBER ALREADY DEFINED" 
C 
7050  CALL EMESS(LVDEF) 
      GOTO 55 
      END