FTN 
      PROGRAM INIT2(5,90),92069-16015 REV.2026 800425 
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-18017
C     RELOC:     92069-16015
C 
C 
C****************************************************************:
C 
C 
C ABSTRACT: 
C 
C INIT GETS THE RUN STRING AND OPENS THE FILES OR LOCKS THE 
C LU'S AS REQUIRES. 
C 
C INIT THEN OUTPUTS IT'S HEADING - "IMAGE/1000 DATA DEFINITION
C UTILITY". 
C 
C INIT INITIALIZES GLOBALS, THEN DETERMINES WHETHER TO LOAD 
C THE "BEGIN DATA BASE" PROCESSOR OR THE "$CONTROL:" PROCESSOR. 
C 
C 
C 
C 
C 
      INTEGER CNTR(3),HEAD(3) 
      INTEGER PURGE(3)
      INTEGER IBUF(10)
      INTEGER SIZE(4) 
      INTEGER HD(32),HDZ
      INTEGER ROTMX 
      INTEGER LOCKED(12)
      LOGICAL IFTTY 
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
      EXTERNAL IFTTY
      DATA CNTR/2HCN,2HTR,2H2 / 
      DATA HEAD/2HHE,2HAD,2H2 / 
      DATA PURGE/2HPU,2HRG,2HE /
      DATA SIZE/0,10,0,0/ 
      DATA HD/2H  ,2H  ,2H  ,2HHE,2HWL,2HET,2HT-,2HPA,2HCK,2HAR,
     12HD ,2HIM,2HAG,2HE/,2H10,2H00,2H D,2HAT,2HA ,2HBA,
     22HSE,2H D,2HEF,2HIN,2HIT,2HIO,2HN ,2HPR,2HOC,2HES,
     32HSO,2HR /
      DATA LOCKED/2H D,2HBD,2HS ,2HWA,2HIT,2HIN,2HG ,2HON,2H L, 
     &    2HIS,2HT ,2HLU/ 
      DATA HDZ/32/
C 
C 
C 
C                INITIALIZATION 
C 
C 
C 
C 
C GET INPUT PARAMETER 
C 
      CRDPR = 1 
      CALL NAMR(IBUF,CARD,ICNT,CRDPR) 
C 
C SET INPUT LU TO ZERO AND ERROR CODE TO ZERO IN CASE 
C INPUT NAMR IS AN LU 
C 
      INPUT = -1
      IERR = 0
C 
C IS INPUT NAMR A FILE? 
C 
      IF (IAND(IBUF(4),000003B) .NE. 3) GOTO 10 
C 
C YES, OPEN THE FILE
C 
      CALL OPEN(IDCB,IERR,IBUF,0,IBUF(5),IBUF(6) )
      GO TO 20
C 
C NO, THEN INPUT IS AN LU 
C 
10    CONTINUE
      INPUT = IBUF(1) 
C 
C DEFAULT LU IF NECESSARY 
C 
      IF(INPUT .EQ. 0) INPUT = 1
      IF(INPUT .GT. 0) GOTO 12
      IERR = -1 
      GOTO 20 
C 
C LOCK THE INPUT DEVIVE WHEN NECESSARY
C 
12    CONTINUE
      IF(IFTTY(INPUT) ) GOTO 15 
      CALL LURQ(40001B,INPUT,1) 
      GOTO 13 
8000  GOTO 15 
13    IERR = -1 
C 
C SET CONTROL WORD TO ECHO COMMANDS FROM A KEYBOARD 
C 
15    CONTINUE
      INPUT = INPUT + 400B
C 
C GET THE LIST PARAMETER
C 
20    CONTINUE
      CALL NAMR(IBUF,CARD,ICNT,CRDPR) 
C 
C IS LIST A FILE? 
C 
      LIST = -1 
      IERR2 = 0 
      IF (IAND(IBUF(4),000003B) .NE. 3) GOTO 30 
C 
C YES, OPEN THE FILE
C 
      CALL OPEN (LDCB,IERR2,IBUF,0,IBUF(5),IBUF(6) )
C 
C IF NOT FOUND THEN CREATE THE LIST FILE
C 
      IF(IERR2 .NE. -6) GOTO 25 
      CALL ECREA(LDCB,IERR2,IBUF,SIZE,4,IBUF(5),IBUF(6) ) 
C 
C IF  ERROR THEN ABORT
C 
25    CONTINUE
      IF (IERR2 .LT. 0) CALL ERXIT(0) 
      GO TO 40
C 
C NO, THEN LIST IS A LU 
C 
30    CONTINUE
      LIST = IBUF(1)
C 
C DEFAULT LIST TO LU 6 IF NECESSARY 
C 
      IF (IBUF(4)  .EQ. 0) LIST = 6 
      IF(LIST .LT. 0) CALL ERXIT(0) 
C 
C LOCK THE LU 
C SKIP TO TOP OF PAGE 
C 
      IF(IFTTY(LIST) ) GOTO 35
      CALL LURQ(140001B,LIST,1) 
      GOTO 31 
8010  GOTO 32 
C 
C LU REQUEST ABORTED - TERMINATE DBDS 
C 
31    CONTINUE
      CALL ERXIT(0) 
C 
C WAIT ON LIST LU 
C 
32    CONTINUE
      CALL ABREG(IA,IB) 
      IF(IA .EQ. 0) GOTO 35 
      CALL EXEC(2,1,LOCKED,12)
C 
C WAIT ON THE LU
C 
34    CONTINUE
      CALL EXEC(12,0,2,0,-10) 
      CALL LURQ(140001B,LIST,1) 
      GOTO 31 
8020  CALL ABREG(IA,IB) 
      IF(IA .NE. 0) GOTO 34 
C 
C OUTPUT TOP OF PAGE
C 
35    CALL EXEC(100003B,1100B+LIST,-1)
      GOTO 31 
C 
C GET THE OPTIONS LIST.  IF THE OPTION IS NOT "PURGE", THEN 
C OUTPUT "ILLEGAL OPTION" AND TERMINATE.
C 
40    CONTINUE
      PRGFLG = 0
      CALL NAMR(IBUF,CARD,ICNT,CRDPR) 
      IF(IBUF(4) .EQ. 0) GOTO 50
      IF(IAND(IBUF(4),3B) .NE. 3) CALL ERXIT(ILOPT) 
      IF(JSCOM(IBUF,1,2,PURGE,1) .NE. 0) CALL ERXIT(ILOPT)
      PRGFLG = 1
C 
C OUTPUT A HEADING
C 
50    CONTINUE
      CALL OUTLN(HD,HDZ)
      CALL OUTLN(BLANK,1) 
      CALL OUTLN(BLANK,1) 
      CALL OUTLN(BLANK,1) 
C 
C CHECK FOR INPUT OPEN ERROR
C 
C SET PRINT OPTION TO PRINT ERRONEOUS LINE
C 
      NDX = NFONX(NOLST)
      INFO(NDX) = NFO(NOLST)
C 
      IF (IERR .LT. 0) CALL ERXIT(OPNER)
C 
C OPEN OK,
C 
C   INITIALIZE ERROR COUNT
C 
      ERROR = 0 
C 
      NDX = NFONX(LST)
      INFO(NDX) = NFO(LST)
C 
      NDX = NFONX(ERR)
      INFO(NDX) = NFO(ERR)
C 
C 
C GET ALL AVAILABLE MEMORY
C 
      CALL LIMEM(0,FWAM,ROTMX)
      IF (ROTMX .EQ. 0) CALL ERXIT(NOMEM) 
C 
C MAKE SURE IT IS ALL ADDRESSIBLE BY BYTES. 
C 
      IF (ROTMX .GT. 15360) ROTMX=15360 
      LWAM = FWAM + ROTMX - 1 
C 
C INITIALIZE MEMORY TO ZERO 
C 
      DO 70 I = 0,ROTMX-1 
      CALL SROOT(I,0) 
70    CONTINUE
C 
C INITIALIZE INPUT BUFFERS
C 
      CRDPR = CRDLM*2 
      CALL GCHAR
      CALL GGLOB
C 
C DECIDE WHAT SEGMENTS TO LOAD
C 
C 
C IS COMMAND $CONTROL ? 
C 
      IF (RESNO .NE. CNTRL) GOTO 80 
       CALL SEGLD(CNTR,IERR)
C 
C IF RETURN FROM SEGLD THEN ERROR 
C 
      CALL OUTLN(CNTR,2)
      CALL ERXIT(NOSEG) 
C 
C NO, SO LOAD HEAD
C 
80    CONTINUE
      CALL SEGLD(HEAD,IERR) 
C 
C IF RETURN FROM SEGLD THEN ERROR - ABORT 
C 
      CALL OUTLN(HEAD,3)
      CALL ERXIT(NOSEG) 
      END