FTN SUBROUTINE ITMT(ECNT,IINDX,IERR),92069-16015 REV.2026 800124 INTEGER ECNT 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-18040 C RELOC: 92069-16015 C C C****************************************************************: C C C C ABSTRACT: C C THIS SUBROUTINE PROCESSES THE TYPE PARAMETER OF THE "ITEMS:" COMMAND. C THE ITEM TYPE AND THE ITEM LENGTH IS PUT INTO THE ITEM TABLE FOR THE C SPECIFIED ITEM. THE SUBROUTINE INSURES THE CALLER THAT THE LENGTH C OF THE ENTIRE ITEM FIELD IS NOT LARGER THAN THE MAXIMUM SIZE. C C THE SYNTAX OF THE "ITEMS:" COMMAND IS AS FOLLOWS: C C ITEMS: C ITEM NAME, [ELEMENT COUNT] ITEM TYPE [(READ LEVEL,WRITE LEVEL)] ; C C C WHERE: C C ITEM TYPE C IS ONE OF THE FOLLOWING: C C I1 - SINGLE WORD INTEGER C R2 - SINGLE PRECISION REAL C XN - ASCII STRING C N IS THE NUMBER OF CHARACTERS IN THE STRING C N * ELEMENT COUNT MUST BE EVEN. C C C C C CALLING SEQUENCE: C C CALL ITMT(ECNT,IINDX,IERR) C C WHERE: C C ECNT C IS THE ELEMENT COUNT RETURNED FROM THE SUBROUTINE ELEMT C C IINDX C IS THE INDEX INTO THE ITEM TABLE C C IERR C IS RETURNED BY THE SUBROUTINE. IT INDICATES ERRORS. C 0 INDICATES NO ERROR C C -1 INDICATES AN ERROR. THE ERROR MESSAGE IS WRITTEN C TO THE LIST DEVICE BEFORE THIS SUBROUTINE RETURNS C TO THE CALLER. C C C C INTEGER R,II,X 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 R/000122B/ DATA II/00111B/ DATA X/00130B/ C C SET ERROR RETURN TO INDICATE AN ERROR C IERR = -1 C C VERIFY THAT A TYPE SPECIFICATION WAS GIVEN C IF (TYPE .NE. NAM ) GOTO 7010 C C PUT FIRST CHARACTER OF TYPE SPEC IN ITEM TABLE C CALL SGET(IGLOB,1,ITYPE) CALL RSPUT(IINDX+ITTYP,ITYPE) C C C CONVERT IGLOB TO AN INTEGER C CALL CATI(IGLOB,2,2*LGLOB,NUM,IIERR) IF(IIERR .LT.0) GOTO 7010 C C LENGTH OF ITEM = LENGTH OF FIELD * # OF ELEMENTS C I = NUM*ECNT C C VERIFY TYPE SPECIFICATION C IF ( (ITYPE .EQ. R) .AND. (NUM .EQ. 2) ) GOTO 80 IF ( (ITYPE .EQ. II) .AND. (NUM .EQ. 1) ) GOTO 80 IF ((ITYPE .NE. X) .OR. (NUM .GT.MXSTR) )GOTO 7010 C C SET I2 TO INDICATE ODD OR EVEN C I2 = 0 IMPLIES EVEN C I2 = 1 IMPLIES ODD C I2 = I - (I/2 * 2) C C SET I TO WORD COUNT C I = I/2 IF((I2 .NE. 0) .OR. (I .LT. 1) ) GOTO 7020 IF (I .GT. MAXRC-1 ) GOTO 7010 C C PUT THE ITEM LENGTH IN THE ITEM TABLE C 80 CONTINUE CALL SROOT(IINDX+ITLNG,I) IERR = 0 90 CONTINUE RETURN C C C C ERROR PROCESSORS C C C OUTPUT "BAD TYPE DESIGNATOR" C 7010 CALL EMESS(ILITP) GOTO 90 C C OUTPUT "TOTAL ITEM LENGTH NOT INTEGRAL WORDS" C 7020 CALL EMESS(ILXTP) GOTO 90 END