*     COPYRIGHT, (C) HONEYWELL INFORMATION SYSTEMS INC., 1979, 1980
*
      BLOCK DATA COPYRIT2
      INTEGER COPYRITE(16)
     1   /'COPYRIGHT, (C) HONEYWELL INFORMATION SYSTEMS INC., 1979,'
     2  , ' 1980.  '/
      GLOBAL COPYRITE
      END
      SUBROUTINE SCHINI
************************************************************************
*                                                                      *
*            SUBROUTINE SCHINI                       @1978 11 01       *
*                                                                      *
*     SCHEMA DEFINITION INITIALIZATIONS:                               *
*            STORES VALUES INTO THE ELEMENTS OF /CONSTS/, DEFINES      *
*            THE UNIT NUMBER USSCHM. ZEROES SSCCNT.                    *
*                                                                      *
************************************************************************
      IMPLICIT LOGICAL(A-Z)
      INCLUDE EVAL_IN01,LIST
      USSCHM=1
      SSCCNT=0
      RETURN
      END
      SUBROUTINE BLSCHM(ERRCD)
************************************************************************
*                                                                      *
*            SUBROUTINE BLSCHM                       @1978 11 01       *
*                                                                      *
*     USES DUMPS FROM THE DATABASE SUBSCHEMAS TO CONSTRUCT             *
*     A DEFINITION OF THE DATABASE. DEFINES THE STRUCTURES             *
*     REQUIRED FOR THE EXTRACTION AND VALIDATION PROCESSES             *
*                                                                      *
************************************************************************
      IMPLICIT LOGICAL(A-Z)
      LOGICAL EODFLG
************************************************************************
*                                                                      *
*     LOCAL VARIABLES:                                                 *
*                                                                      *
*            NAME     TYPE        DESCRIPTION                          *
*            ----     ----        -----------                          *
*            ERRCD    INTEGER     ERROR CODE ON COMPLETION OF AN       *
*                                 OPERATION. ERRCD=0 NO ERROR.         *
*            INDEX0   INTEGER     A SCRATCH VARIABLE                   *
*            INDEX1   INTEGER     A NUTHER SCRATCH VARIABLE            *
*            EODFLG   LOGICAL     FLAG TO SIGNAL END OF DATA ON A      *
*                                 TYPE OF RECORD IN THE SCHEMA FILE    *
*                                                                      *
************************************************************************
*** EXTERNAL COMMONS
*
      INTEGER UERROR,UUSERI,UUSERO
      COMMON /USERIO/UERROR,UUSERI,UUSERO
*
***
      INCLUDE EVAL_IN01
      INCLUDE EVAL_IN04,LIST
****************************************
*                                      *
*            INITIALIZATION            *
*                                      *
****************************************
      ARACNT=0
      GRPCNT=0
      DO 20 INDEX0=1,267
      GRPITB(INDEX0)=0
20    CONTINUE
      SETCNT=0
      DEFCNT=0
*
*  INITIALIZE THE CSGP FILE BUFFER
*
      CALL RDSSCH(ERRCD)
      IF(ERRCD.NE.0)GOTO 140
****************************************
*            DEFINITION                *
*                                      *
****************************************
*
*  DEFINE AREAS
*
10    CONTINUE
      CALL RDARAR(EODFLG,ERRCD)
      IF(ERRCD.NE.0)GOTO 40
      IF(EODFLG)GOTO 30
      CALL PUTARA(ERRCD)
      IF(ERRCD.NE.0)GOTO 50
      GOTO 10
*
*  DEFINE GROUPS
*
30    CONTINUE
      CALL RDGRPR(EODFLG,ERRCD)
      IF(ERRCD.NE.0)GOTO 60
      IF(EODFLG)GOTO 70
      CALL PUTGRP(ERRCD)
      IF(ERRCD.NE.0)GOTO 80
      GOTO 30
*
*  DEFINE SETS
*
70    CONTINUE
      CALL CSPDEF(ERRCD)
      IF(ERRCD.NE.0)GOTO 140
100   CONTINUE
      CALL RDSETR(EODFLG,ERRCD)
      IF(ERRCD.NE.0)GOTO 110
      IF(EODFLG)GOTO 120
      CALL PUTSET(ERRCD)
      IF(ERRCD.NE.0)GOTO 130
      GOTO 100
120   CONTINUE
*
*  BUILD SET LIST FOR EACH GROUP
*
      DO 150 INDEX0=1,GRPCNT
      SETLISCT(INDEX0)=0
      DO 160 INDEX1=1,SETCNT
      IF(TPYLNK(INDEX1,INDEX0).EQ.0)GOTO 160
      IF(SETLISCT(INDEX0).EQ.AVGSETS)WRITE(UERROR,8000)AVGSETS;
     @ERRCD=1;GOTO 140
8000  FORMAT(' SET LIST TABLE OVERFLOW.  INCREASE PARAMETER "AVGSETS".'
     @/' CURRENT VALUE IS ',I)
      SETLISCT(INDEX0)=SETLISCT(INDEX0)+1
      SETLIST(INDEX0,SETLISCT(INDEX0))=INDEX1
160   CONTINUE
150   CONTINUE
      RETURN
****************************************
*                                      *
*            ERROR RETURNS             *
*                                      *
****************************************
40    CONTINUE
      WRITE(UERROR,1000)
      GOTO 140
50    CONTINUE
      WRITE(UERROR,2000)
2000  FORMAT(' ERRORED DEFINING AREA')
      GOTO 140
60    CONTINUE
      WRITE(UERROR,3000)
3000  FORMAT(' ERRORED READING GROUP RECORD')
      GOTO 140
80    CONTINUE
      WRITE(UERROR,4000)
4000  FORMAT(' ERRORED DEFINING GROUP')
      GOTO 140
110   CONTINUE
      WRITE(UERROR,5000)
5000  FORMAT(' ERRORED READING SET RECORD')
      GOTO 140
130   CONTINUE
      WRITE(UERROR,6000)
6000  FORMAT(' ERRORED DEFINING SET')
140   CONTINUE
      WRITE(UERROR,7000)SSCCNT
7000  FORMAT(' DATABASE DEFINITION ABORTED'/
     @' TERMINATION AFTER ',I,'RECORDS INPUT')
      RETURN
      END
      SUBROUTINE CSPDEF(ERRCD)
************************************************************************
*                                                                      *
*            SUBROUTINE CSPDEF                       @1978 11 01       *
*                                                                      *
*     DEFINES A DUMMY GROUP AND DUMMY SET FOR THE CONTROL SET          *
*     POINTER CHAIN ON EACH DATA PAGE.                                 *
*     THE DUMMY SET HAS AS ITS MEMBERS ALL CALC OR INDEX               *
*     GROUPS.                                                          *
*                                                                      *
************************************************************************
      IMPLICIT LOGICAL(A-Z)
      INTEGER GNAME,SNAME,INDEX0,ERRCD
      DIMENSION GNAME(12),SNAME(9)
      DATA GNAME/11,'$','P','A','G','E','H','E','A','D','E','R'/
      DATA SNAME/8,'$','C','O','N','T','R','O','L'/
*                                                                      *
*     LOCAL VARIABLES:                                                 *
*                                                                      *
*            NAME     TYPE        DESCRIPTION                          *
*            ----     ----        -----------                          *
*            ERRCD    INTEGER     ERROR CODE ON COMPLETION OF AN       *
*                                 OPERATION. ERRCD=0 NO ERROR.         *
*            INDEX0   INTEGER     A SCRATCH VARIABLE                   *
*            GNAME    CONSTANT    BUFFER CONTAINING THE GROUP NAME     *
*            SNAME    CONSTANT    BUFFER CONTAINING THE SET NAME       *
*                                                                      *
************************************************************************
*** EXTERNAL COMMONS
*
      INTEGER UERROR,UUSERI,UUSERO
      COMMON /USERIO/UERROR,UUSERI,UUSERO
*
***
      INCLUDE EVAL_IN01
      INCLUDE EVAL_IN04
      DATA GNAME/11,'$','P','A','G','E','H','E','A','D','E','R'/
      DATA SNAME/8,'$','C','O','N','T','R','O','L'/
****************************************
*                                      *
*     CSP GROUP DEFINITION             *
*                                      *
*     GENERATE GROUP DEFINITION INTO   *
*     /GRPREC/ AND CALL PUTGRP         *
*                                      *
****************************************
*
*     GROUP NUMBER IS 131072, LARGER THAN THE MAXIMUM
*     VALUE OBTAINABLE FROM A SUBSCHEMA
*
      GRPNUM=131072
      GRPLOC=1
      GRPMAN=.FALSE.
      GRPWDS=2
      GRPWSS=1
      GRPDBY=4
*
*     THE GROUP APPEARS ON ALL DATA PAGES, THEREFORE THERE
*     IS NO PAGE RANGE RESTRICTION.
*
      GRPPMN=-1
      GRPPMX=-1
      DO 10 INDEX0=1,12
      GRPNBF(INDEX0)=GNAME(INDEX0)
10    CONTINUE
      GRPSCT=1
*
*     SET NUMBER IS 33554432, LARGER THAN THE MAXIMUM
*     VALUE OBTAINABLE FROM THE CSGP FILE.
*
      GRPSBF(1)=33554432
*
*     THE GROUP OCCURS IN ALL AREAS, SO THE VALUE FOR
*     GROUP AREA IS ZERO TO IMPLY THIS
*
      GRPRYA=0
      CALL PUTGRP(ERRCD)
      IF(ERRCD.NE.0)GOTO 20
****************************************
*                                      *
*     CSP SET DEFINITION               *
*                                      *
*     GENERATE SET DEFINITION INTO     *
*     /SETREC/ AND CALL PUTSET         *
*                                      *
****************************************
      SETNUM=33554432
      SETONR=131072
      SETONP=4
      IF(ARACNT.EQ.1)SETONP=5
      SETOPP=0
      DO 30 INDEX0=1,9
      SETNBF(INDEX0)=SNAME(INDEX0)
30    CONTINUE
      SETMCT=0
      DO 40 INDEX0=1,GRPCNT
      IF(GRPLCM(INDEX0).LE.1)GOTO 40
      SETMCT=SETMCT+1
      SETMBF(SETMCT)=GROUP(INDEX0)
      SETMIM(SETMCT)=0
      SETPBF(SETMCT,1)=SETONP
      SETPBF(SETMCT,2)=0
      SETPBF(SETMCT,3)=0
40    CONTINUE
      CALL PUTSET(ERRCD)
      IF(ERRCD.NE.0)GOTO 50
      RETURN
20    CONTINUE
      WRITE(UERROR,1000)
1000  FORMAT(' ERRORED WHILE DEFINING $PAGEHEADER')
      GOTO 60
50    CONTINUE
      WRITE(UERROR,2000)
2000  FORMAT(' ERRORED WHILE DEFINING $CONTROL')
60    CONTINUE
      RETURN
      END
      SUBROUTINE RDARAR(EODFLG,ERRCD)
************************************************************************
*                                                                      *
*            SUBROUTINE RDARAR(ERRCD)                @1978 11 01       *
*                                                                      *
*     SKIPS TO (IF NECESSARY) AREA DEFINITION RECORDS IN THE           *
*     DUMP FROM THE DATABASE SUBSCHEMAS. INTERPRETS THESE RECORDS      *
*     TO FORM AN AREA RECORD (COMMON BLOCK /ARAREC/).                  *
*     EODFLG IS REUTRNED TRUE IFF NO MORE AREA DEFINITIONS EXIST.      *
*     AN AREA DEFINITION RECORD FROM THE DUMP FILE HAS RECORD          *
*     TYPE CODE (WORD 2; SSCHBUF(2)) EQUAL TO ARATYP.                  *
*                                                                      *
************************************************************************
      IMPLICIT LOGICAL(A-Z)
      INTEGER ERRCD,INDEX0,NAMWDS,ARATYP
      LOGICAL EODFLG
      DATA ARATYP/1/
************************************************************************
*                                                                      *
*     LOCAL VARIABLES:                                                 *
*            NAME     TYPE        DESCRIPTION                          *
*            ----     ----        -----------                          *
*            ERRCD    INTEGER     ERROR CODE ON COMPLETION OF AN       *
*                                 OPERATION. ERRCD=0 NO ERROR.         *
*            INDEX0   INTEGER     A SCRATCH VARIABLE                   *
*            NAMWDS   INTEGER     NUMBER OF WORDS IN THE AREA NAME     *
*            ARATYP   CONSTANT    RECORD TYPE CODE FOR AREA DEFINITION *
*                                 IN SCHEMA FILE                       *
*                                                                      *
************************************************************************
*** EXTERNAL COMMONS
*
      INTEGER UERROR,UUSERI,UUSERO
      COMMON /USERIO/UERROR,UUSERI,UUSERO
*
***
      INCLUDE EVAL_IN01
      INCLUDE EVAL_IN04
      ERRCD=0
      EODFLG=.FALSE.
****************************************
*                                      *
*  SKIP TO AREA DEFINITION RECORD      *
*                                      *
****************************************
10    CONTINUE
      IF(SSCBUF(2)-ARATYP)20,30,40
20    CONTINUE
      CALL RDSSCH(ERRCD)
      IF(ERRCD.NE.0)GOTO 50
      GOTO 10
****************************************
*                                      *
*  INTERPRET AREA DEFINITION RECORD    *
*                                      *
****************************************
30    CONTINUE
      ARANUM=SSCBUF(6)
      ARAPGS=SSCBUF(5)
      ARABPL=SSCBUF(9)
      ARACSM=.FALSE.
      IF(SSCBUF(8).EQ.1)ARACSM=.TRUE.
      ARACIF=.FALSE.
      IF(SSCBUF(10).EQ.1)ARACIF=.TRUE.
      ARAIKS=SSCBUF(13)
*
*  AREA NAME
*
      NAMWDS=SSCBUF(17)+1
      IF(NAMWDS.EQ.0)GOTO 70
      DO 60 INDEX0=1,NAMWDS
      ARANBF(INDEX0)=SSCBUF(16+INDEX0)
60    CONTINUE
70    CONTINUE
*
*  DONE WITH THIS RECORD, GET THE NEXT
*
      CALL RDSSCH(ERRCD)
      IF(ERRCD.NE.0)GOTO 50
      RETURN
****************************************
*                                      *
*                                      *
****************************************
40    CONTINUE
      EODFLG=.TRUE.
      RETURN
****************************************
*                                      *
*            ERROR RETURNS             *
*                                      *
****************************************
50    CONTINUE
      WRITE(UERROR,1000)
1000  FORMAT(' ERROR EXIT FROM RDARAR')
      RETURN
      END
      SUBROUTINE RDGRPR(EODFLG,ERRCD)
************************************************************************
*                                                                      *
*            SUBROUTINE RDGRPR(ERRCD)                @1978 11 01       *
*                                                                      *
*     SKIPS TO (IF NECESSARY) GROUP DEFINITION RECORDS IN THE          *
*     DUMP FROM THE DATABASE SUBSCHEMAS. INTERPRETS THESE RECORDS      *
*     TO FORM A GROUP RECORD (COMMON BLOCK /GRPREC/).                  *
*     EODFLG IS REUTRNED TRUE IFF NO MORE GROUP DEFINITIONS EXIST.     *
*     A GROUP DEFINITION RECORD FROM THE DUMP FILE HAS RECORD          *
*     TYPE CODE (WORD 2; SSCHBUF(2)) EQUAL TO GRPTYP.                  *
*                                                                      *
************************************************************************
      IMPLICIT LOGICAL(A-Z)
      INTEGER ERRCD,INDEX0,NAMWDS,BASE,GRPTYP,GRPSCD
      LOGICAL EODFLG
      DATA GRPTYP/2/,GRPSCD/0/
************************************************************************
*                                                                      *
*     LOCAL VARIABLES:                                                 *
*            ----     ----        -----------                          *
*            ERRCD    INTEGER     ERROR CODE ON COMPLETION OF AN       *
*                                 OPERATION. ERRCD=0 NO ERROR.         *
*            INDEX0   INTEGER     A SCRATCH VARIABLE                   *
*            NAMWDS   INTEGER     NUMBER OF WORDS IN THE GROUP NAME    *
*            BASE     INTEGER     NUMBER OF FIRST WORD IN SSCBUF       *
*                                 FOLLOWING THE GROUP NAME             *
*            GRPTYP   CONSTANT    RECORD TYPE CODE FOR GROUP DEFINITION*
*            GRPSCD   CONSTANT    RECORD SUBCODE FOR GROUP DEFINITION  *
*            EODFLG   LOGICAL     FLAG SIGNALLING END OF GROUP RECORDS *
*                                 IN SCHEMA FILE                       *
*                                                                      *
************************************************************************
*** EXTERNAL COMMONS
*
      INTEGER UERROR,UUSERI,UUSERO
      COMMON /USERIO/UERROR,UUSERI,UUSERO
*
***
      INCLUDE EVAL_IN01
      INCLUDE EVAL_IN04
      ERRCD=0
      EODFLG=.FALSE.
****************************************
*                                      *
*  SKIP TO GROUP DEFINITION RECORD     *
*                                      *
****************************************
10    CONTINUE
      IF(SSCBUF(2)-GRPTYP)20,30,40
20    CONTINUE
      CALL RDSSCH(ERRCD)
      IF(ERRCD.NE.0)GOTO 50
      GOTO 10
****************************************
*                                      *
*  INTERPRET GROUP DEFINITION RECORD   *
*                                      *
****************************************
30    CONTINUE
      IF(SSCBUF(3).NE.GRPSCD)GOTO 20
      GRPNUM=SSCBUF(4)
      GRPLOC=SSCBUF(9)
      GRPWDS=SSCBUF(10)
      GRPWSS=SSCBUF(11)
      GRPDBY=SSCBUF(16)
      GRPPMN=SSCBUF(12)
      GRPPMX=SSCBUF(13)
*
*  GROUP NAME
*
      NAMWDS=SSCBUF(20)+1
      IF(NAMWDS.EQ.0)GOTO 80
      DO 60 INDEX0=1,NAMWDS
      GRPNBF(INDEX0)=SSCBUF(19+INDEX0)
60    CONTINUE
80    CONTINUE
*
*  GROUP SETS
*
      BASE=20+NAMWDS
      GRPSCT=SSCBUF(BASE)
      IF(GRPSCT.EQ.0)GOTO 90
      DO 70 INDEX0=1,GRPSCT
      GRPSBF(INDEX0)=SSCBUF(BASE+INDEX0)
70    CONTINUE
90    CONTINUE
      GRPRYA=SSCBUF(1)
*
*  DONE WITH THIS RECORD, GET THE NEXT
*
      CALL RDSSCH(ERRCD)
      IF(ERRCD.NE.0)GOTO 50
      RETURN
****************************************
*                                      *
*  NO MORE GROUP RECORDS--EOD          *
*                                      *
****************************************
40    CONTINUE
      EODFLG=.TRUE.
      RETURN
****************************************
*                                      *
*            ERROR RETURNS             *
*                                      *
****************************************
50    CONTINUE
      WRITE(UERROR,1000)
1000  FORMAT(' ERROR EXIT FROM RDGRPR')
      RETURN
      END
      SUBROUTINE RDSETR(EODFLG,ERRCD)
************************************************************************
*                                                                      *
*            SUBROUTINE RDSETR(ERRCD)                @1978 11 01       *
*     SKIPS TO (IF NECESSARY) SET DEFINITION RECORDS IN THE            *
*     DUMP FROM THE DATABASE SUBSCHEMAS. INTERPRETS THESE RECORDS      *
*     TO FORM A SET RECORD (COMMON BLOCK /SETREC/).                    *
*       EODFLG IS REUTRNED TRUE IFF NO MORE SET DEFINITIONS EXIST.     *
*     A SET DEFINITION RECORD FROM THE DUMP FILE HAS RECORD            *
*     TYPE CODE (WORD 2; SSCHBUF(2)) EQUAL TO SETTYP.                  *
*                                                                      *
************************************************************************
      IMPLICIT LOGICAL(A-Z)
      INTEGER ERRCD,INDEX0,INDEX1,NAMWDS,BASE,SETTYP,SETSCD
      LOGICAL EODFLG
      DATA SETTYP/3/,SETSCD/0/
************************************************************************
*                                                                      *
*     LOCAL VARIABLES:                                                 *
*            NAME     TYPE        DESCRIPTION                          *
*            ----     ----        -----------                          *
*            ERRCD    INTEGER     ERROR CODE ON COMPLETION OF AN       *
*                                 OPERATION. ERRCD=0 NO ERROR.         *
*            INDEX0   INTEGER     A SCRATCH VARIABLE                   *
*            NAMWDS   INTEGER     NUMBER OF WORDS IN THE SET NAME      *
*            BASE     INTEGER     ORIGIN FOR SET NAME,                 *
*                                 ORIGIN FOR SET MEMBER COUNTS IN      *
*                                 SSCBUF, ORIGIN FOR POINTER POSITION  *
*                                 WORDS IN SSCBUF                      *
*            SETTYP   CONSTANT    RECORD TYPE CODE FOR SET DEFINITION  *
*            SETSCD   CONSTANT    RECORD SUBCODE FOR SET DEFINITION    *
*                                 IN SCHEMA FILE                       *
*                                                                      *
************************************************************************
*** EXTERNAL COMMONS
*
      INTEGER UERROR,UUSERI,UUSERO
      COMMON /USERIO/UERROR,UUSERI,UUSERO
*
***
      INCLUDE EVAL_IN01
      INCLUDE EVAL_IN04
      ERRCD=0
      EODFLG=.FALSE.
****************************************
*                                      *
*  SKIP TO SET DEFINITION RECORD       *
*                                      *
****************************************
10    CONTINUE
      IF(SSCBUF(2)-SETTYP)20,30,40
20    CONTINUE
      CALL RDSSCH(ERRCD)
      IF(ERRCD.NE.0)GOTO 50
      GOTO 10
****************************************
*                                      *
*  INTERPRET SET RECORD                *
*                                      *
****************************************
30    CONTINUE
      IF(SSCBUF(3).NE.SETSCD)GOTO 20
      SETRYA=SSCBUF(1)
      SETNUM=SSCBUF(4)
      SETONR=SSCBUF(5)
      SETONP=SSCBUF(8)
      SETOPP=SSCBUF(9)
*
*  SKIP TO SET NAME
*
      BASE=11+SSCBUF(11)
      NAMWDS=SSCBUF(BASE+1)+1
      IF(NAMWDS.EQ.0)GOTO 90
      DO 60 INDEX0=1,NAMWDS
      SETNBF(INDEX0)=SSCBUF(BASE+INDEX0)
60    CONTINUE
90    CONTINUE
*
*  MEMBERS AND THEIR POINTER POSITIONS
*
      BASE=BASE+NAMWDS+1
      SETMCT=SSCBUF(BASE)
      IF(SETMCT.EQ.0)GOTO 100
      BASE=BASE+1
      DO 70 INDEX0=1,SETMCT
      SETMBF(INDEX0)=SSCBUF(BASE+INDEX1)
      SETMIM(INDEX0)=SSCBUF(BASE+INDEX1+1)
      SETPBF(INDEX0,1)=SSCBUF(BASE+INDEX1+2)
      SETPBF(INDEX0,2)=SSCBUF(BASE+INDEX1+3)
      SETPBF(INDEX0,3)=SSCBUF(BASE+INDEX1+4)
70    CONTINUE
100   CONTINUE
*
*  DONE WITH THIS RECORD, GET THE NEXT
*
      CALL RDSSCH(ERRCD)
      IF(ERRCD.NE.0)GOTO 50
      RETURN
****************************************
*                                      *
*  NO MORE SET RECORDS--EOD            *
*                                      *
****************************************
40    CONTINUE
      EODFLG=.TRUE.
      RETURN
****************************************
*                                      *
*            ERROR RETURNS             *
*                                      *
****************************************
50    CONTINUE
      WRITE(UERROR,1000)
1000  FORMAT(' ERROR EXIT FROM RDSETR')
      RETURN
      END
      SUBROUTINE RDSSCH(ERRCD)
************************************************************************
*                                                                      *
*            SUBROUTINE RDSSCH                       @1978 11 01       *
*                                                                      *
*     READS A RECORD FROM USSCHM INTO THE SUBSCHEMA FILE               *
*     BUFFER SSCBUF IN /SSCREC/                                        *
*                                                                      *
************************************************************************
      IMPLICIT LOGICAL(A-Z)
      INTEGER READST,ERRCD,EOFCD
      DATA EOFCD/8ZFFFFFFFF/
*                                                                      *
*     LOCAL VARIABLES:                                                 *
*            NAME     TYPE        DESCRIPTION                          *
*            ----     ----        -----------                          *
*            ERRCD    INTEGER     ERROR CODE ON COMPLETION OF READ     *
*                                 OPERATION. ERRCD=0 NO ERROR.         *
*            READST   INTEGER     RETURNED BY "BUFFER IN" ROUTINE      *
*            EOFCD    CONSTANT    RECORD TYPE CODE TO SIGNAL EOF       *
*                                                                      *
************************************************************************
*** EXTERNAL COMMONS
*
      INTEGER UERROR,UUSERI,UUSERO
      COMMON /USERIO/UERROR,UUSERI,UUSERO
*
***
      INCLUDE EVAL_IN01
      INCLUDE EVAL_IN04
      ERRCD=0
      CALL BUFFER IN(USSCHM,1,SSCBUF,SSCBFM,READST,SSCBFS)
      GOTO(10,20,30),READST
      GOTO 10
20    CONTINUE
      SSCCNT=SSCCNT+1
      RETURN
*
*  EOFCD FOR RECORD TYPE SERVES AS EOD FOR ALL TYPES
*
30    CONTINUE
      SSCBUF(2)=EOFCD
      RETURN
*
*  ERROR IN BUFFER IN OPERATION
*
10    CONTINUE
      ERRCD=1
      WRITE(UERROR,1000)READST,USSCHM
1000  FORMAT(' BUFFER IN ERROR WITH CODE ',I,'DURING DATABASE DEFN.'/
     @' ERRORED ON UNIT ',I)
      RETURN
      END
      SUBROUTINE PUTARA(ERRCD)
************************************************************************
*                                                                      *
*            SUBROUTINE PUTARA                       @1978 11 01       *
*     ADDS THE DATA FROM THE AREA RECORD /ARAREC/ TO THE TABLES        *
*     IN THE AREA DEFINITION /ARADEF/                                  *
*                                                                      *
*     POSSIBLE ERROR RETURNS:                                          *
*                                                                      *
*            A)  TOO MANY AREAS DEFINED                                *
*            B)  AREA ALREADY DEFINED                                  *
*                                                                      *
************************************************************************
      IMPLICIT LOGICAL(A-Z)
      INTEGER ERRCD,INDEX0,NAMWDS,FNDARA
************************************************************************
*                                                                      *
*     LOCAL VARIABLES:                                                 *
*            NAME     TYPE        DESCRIPTION                          *
*            ----     ----        -----------                          *
*            ERRCD    INTEGER     ERROR CODE ON COMPLETION OF AN       *
*                                 OPERATION. ERRCD=0 NO ERROR.         *
*            INDEX0   INTEGER     A SCRATCH VARIABLE                   *
*            NAMWDS   INTEGER     NUMBER OF WORDS IN THE AREA NAME     *
*            FNDARA   FUNCTION    RETURNS THE INDEX NUMBER OF AN AREA  *
*                                                                      *
************************************************************************
*** EXTERNAL COMMONS
*
      INTEGER UERROR,UUSERI,UUSERO
      COMMON /USERIO/UERROR,UUSERI,UUSERO
*
***
      INCLUDE EVAL_IN01
      ERRCD=1
      IF(FNDARA(ARANUM).NE.0)GOTO 10
      IF(ARACNT.EQ.ARALIM)GOTO 20
      ERRCD=0
      ARACNT=ARACNT+1
****************************************
*                                      *
*            DATA TRANSFER             *
*                                      *
****************************************
      AREA(ARACNT)=ARANUM
      ARASIZ(ARACNT)=ARAPGS
      ARALSZ(ARACNT)=ARABPL
      ARAISZ(ARACNT)=ARAIKS
*
*  AREA NAME
*
      NAMWDS=ARANBF(1)+1
      IF(NAMWDS.EQ.0)GOTO 40
      DO 30 INDEX0=1,NAMWDS
      ARANAM(ARACNT,INDEX0)=ARANBF(INDEX0)
30    CONTINUE
40    CONTINUE
      ARACHK(ARACNT)=ARACSM
      ARACFR(ARACNT)=ARACIF
      RETURN
****************************************
*                                      *
*     ERROR RETURNS                    *
*                                      *
****************************************
10    CONTINUE
      WRITE(UERROR,1000)ARANUM
1000  FORMAT(' ATTEMPT TO DOUBLY DEFINE AREA #',I)
      RETURN
20    CONTINUE
      WRITE(UERROR,2000)ARALIM
2000  FORMAT(' TRIED TO DEFINE TOO MANY AREAS. LIMIT IS ',I)
      RETURN
      END
      SUBROUTINE PUTGRP(ERRCD)
************************************************************************
*                                                                      *
*            SUBROUTINE PUTGRP                       @1978 11 01       *
*                                                                      *
*     ADDS THE DATA FROM THE GROUP RECORD /GRPREC/ TO THE TABLES       *
*     IN THE GROUP DEFINITION /GRPDEF/                                 *
*     POSSIBLE ERROR RETURNS:                                          *
*                                                                      *
*            A)  TOO MANY GROUPS DEFINED                               *
*            B)  GROUP ALREADY DEFINED                                 *
*                                                                      *
************************************************************************
      IMPLICIT LOGICAL(A-Z)
      INTEGER ERRCD,INDEX0,NAMWDS,WORD,BYTE,FNDGRP,PUTFLD
************************************************************************
*                                                                      *
*     LOCAL VARIABLES:                                                 *
*            NAME     TYPE        DESCRIPTION                          *
*            ----     ----        -----------                          *
*            ERRCD    INTEGER     ERROR CODE ON COMPLETION OF AN       *
*                                 OPERATION. ERRCD=0 NO ERROR.         *
*            INDEX0   INTEGER     A SCRATCH VARIABLE                   *
*            NAMWDS   INTEGER     NUMBER OF WORDS IN THE GROUP NAME    *
*            WORD     INTEGER     WORD FOR INSERTION INTO GRPITB       *
*            BYTE     INTEGER     BYTE FOR INSERTION INTO GRPITB       *
*            FNDGRP   FUNCTION    RETURNS THE INDEX NUMBER OF A GROUP  *
*            PUTFLD   FUNCTION    PUTS A FIELD IN A WORD               *
*                                                                      *
************************************************************************
*** EXTERNAL COMMONS
*
      INTEGER UERROR,UUSERI,UUSERO
      COMMON /USERIO/UERROR,UUSERI,UUSERO
*
***
      INCLUDE EVAL_IN01
      INCLUDE EVAL_IN04
      ERRCD=1
      IF(FNDGRP(GRPNUM,GRPRYA).NE.0)GOTO 10
      IF(GRPCNT.EQ.GRPLIM)GOTO 20
      GRPCNT=GRPCNT+1
****************************************
*                                      *
*            DATA TRANSFER             *
*                                      *
****************************************
      GROUP(GRPCNT)=GRPNUM
      GRPARA(GRPCNT)=GRPRYA
*
*  GROUP RECORD SIZES
*
      GRPSIZ(GRPCNT,1)=GRPWDS
      GRPSIZ(GRPCNT,2)=GRPWSS
      GRPSIZ(GRPCNT,3)=GRPDBY
*
*  GROUP PAGE RANGE
*
      GRPRNG(GRPCNT,1)=GRPPMN
      GRPRNG(GRPCNT,2)=GRPPMX
*
*  GROUP NAME
*
      NAMWDS=GRPNBF(1)+1
      IF(NAMWDS.EQ.0)GOTO 40
      DO 30 INDEX0=1,NAMWDS
      GRPNAM(GRPCNT,INDEX0)=GRPNBF(INDEX0)
30    CONTINUE
40    CONTINUE
      GRPSET(GRPCNT)=GRPSCT
      GRPLCM(GRPCNT)=GRPLOC
*
*  ADD THE GROUP INDEX TO FNDGRP'S LOOKUP TABLE.
*
      IF(GRPNUM.EQ.131072)WORD=BYTE=0;GOTO 50
      WORD=GRPNUM/4
      BYTE=GRPNUM-4*WORD
50    CONTINUE
      CALL PUTFLD(GRPITB(WORD+1),8*BYTE,8,GRPCNT)
      ERRCD=0
      RETURN
****************************************
*                                      *
*            ERROR RETURNS             *
*                                      *
****************************************
10    CONTINUE
      WRITE(UERROR,1000)GRPNUM
1000  FORMAT(' ATTEMPT TO DOUBLY DEFINE GROUP #',I)
      RETURN
20    CONTINUE
      WRITE(UERROR,2000)GRPLIM
2000  FORMAT(' TRIED TO DEFINE TOO MANY GROUPS. LIMIT IS ',I)
      RETURN
      END
      SUBROUTINE PUTSET(ERRCD)
*                                                                      *
*            SUBROUTINE PUTSET                       @1978 11 01       *
*                                                                      *
*     ADDS THE DATA FROM THE SET RECORD /SETREC/ TO THE TABLES         *
*     IN THE SET DEFINITION /SETDEF/                                   *
*     DEFINES THE TOPOLOGY TABLE IN /TPYDEF/                           *
*                                                                      *
*     POSSIBLE ERROR RETURNS:                                          *
*                                                                      *
*            A)  TOO MANY SETS DEFINED                                 *
*            B)  SET ALREADY DEFINED                                   *
*            C)  OWNER GROUP NOT DEFINED                               *
*            D)  MEMBER GROUP NOT DEFINED                              *
*                                                                      *
************************************************************************
      IMPLICIT LOGICAL(A-Z)
      INTEGER INDEX0,INDEX1,NAMWDS,MBRINX,MBRIBF,ONRINX
      INTEGER ERRCD,FNDGRP,FNDSET
      DIMENSION MBRIBF(50)
************************************************************************
*                                                                      *
*     LOCAL VARIABLES:                                                 *
*            NAME     TYPE        DESCRIPTION                          *
*            ----     ----        -----------                          *
*            ERRCD    INTEGER     ERROR CODE ON COMPLETION OF AN       *
*                                 OPERATION. ERRCD=0 NO ERROR.         *
*            INDEX1   INTEGER     ANOTHER SCRATCH VARIABLE             *
*            NAMWDS   INTEGER     NUMBER OF WORDS IN THE SET NAME      *
*            MBRINX   INTEGER     INDEX NUMBER OF A MEMBER GROUP       *
*            MBRIBF   INTEGER     ARRAY OF MEMBER GROUP INDICIES       *
*            ONRINX   INTEGER     INDEX NUMBER OF THE OWNER GROUP      *
*            FNDGRP   FUNCTION    RETURNS THE INDEX NUMBER OF A GROUP  *
*            FNDSET   FUNCTION    RETURNS THE INDEX NUMBER OF A SET    *
*                                                                      *
************************************************************************
*** EXTERNAL COMMONS
*
      INTEGER UERROR,UUSERI,UUSERO
      COMMON /USERIO/UERROR,UUSERI,UUSERO
*
***
      INCLUDE EVAL_IN01
      INCLUDE EVAL_IN04
      IF(FNDSET(SETNUM).NE.0)GOTO 10
      IF(SETCNT.EQ.SETLIM)GOTO 20
*
*  BUILD OWNER INDEX FROM GROUP TABLES
*
      ONRINX=FNDGRP(SETONR,SETRYA)
      IF(ONRINX.EQ.0)GOTO 60
*
*  BUILD MEMBER INDICES
*
      IF(SETMCT.EQ.0)GOTO 100
      DO 70 INDEX0=1,SETMCT
*
*  WE DONT EXPECT AN OWNER IS AREA GROUP TO BE A MEMBER,
*  SO THE AREA NUMBER GIVEN TO FNDGRP IS ZERO.
*
      MBRINX=FNDGRP(SETMBF(INDEX0),0)
      IF(MBRINX.EQ.0)GOTO 80
      MBRIBF(INDEX0)=MBRINX
70    CONTINUE
100   CONTINUE
      SETCNT=SETCNT+1
*
*  INITIALIZE TOPOLOGY TABLE FOR THIS SET
*
      DO 90 INDEX0=1,GRPCNT
      TPYLNK(SETCNT,INDEX0)=0
90    CONTINUE
      SET(SETCNT)=SETNUM
      SETOWN(SETCNT)=SETONR
*
*  SET NAME
*
      NAMWDS=SETNBF(1)+1
      DO 30 INDEX0=1,NAMWDS
      SETNAM(SETCNT,INDEX0)=SETNBF(INDEX0)
30    CONTINUE
110   CONTINUE
*
*  CHECK THAT THERE IS ROOM IN THE POINTER/INCLUSION MODE TABLES
*  FOR THIS SET DEFINITION.
*
      IF(DEFCNT+SETMCT+1.GT.DEFLIM)GOTO 130
*
*  DEFINE THE OWNER
*
      DEFCNT=DEFCNT+1
      TPYLNK(SETCNT,ONRINX)=DEFCNT
      SETPTR(DEFCNT,1)=SETONP
      SETPTR(DEFCNT,2)=SETOPP
      SETPTR(DEFCNT,3)=0
      GRPINM(DEFCNT)=.FALSE.
*
*  DEFINE THE MEMBERS
*
      DO 40 INDEX0=1,SETMCT
      DEFCNT=DEFCNT+1
      TPYLNK(SETCNT,MBRIBF(INDEX0))=DEFCNT
      DO 50 INDEX1=1,3
      SETPTR(DEFCNT,INDEX1)=SETPBF(INDEX0,INDEX1)
50    CONTINUE
      GRPINM(DEFCNT)=.FALSE.
      IF(SETMIM(INDEX0).EQ.1)GRPINM(DEFCNT)=.TRUE.
40    CONTINUE
120   CONTINUE
      ERRCD=0
      RETURN
****************************************
*                                      *
*            ERROR RETURNS             *
*                                      *
****************************************
10    CONTINUE
      WRITE(UERROR,1000)SETNUM
1000  FORMAT(' ATTEMPT TO DOUBLY DEFINE SET #',I)
      GOTO 140
20    CONTINUE
      WRITE(UERROR,2000)SETLIM
2000  FORMAT(' TRIED TO DEFINE TOO MANY SETS. LIMIT IS ',I)
      GOTO 140
60    CONTINUE
      WRITE(UERROR,3000)SETONR,SETNUM
3000  FORMAT(' THE OWNER ( #',I,') OF SET #',I,'IS NOT DEFINED.')
      GOTO 140
80    CONTINUE
      WRITE(UERROR,4000)SETMBF(INDEX0),SETNUM
4000  FORMAT(' A MEMBER ( #',I,') OF SET #',I,'IS NOT DEFINED.')
      GOTO 140
130   CONTINUE
5000  FORMAT(' POINTER DEFINITION AREA OVERFLOW. LIMIT IS ',I)
140   CONTINUE
      ERRCD=1
      RETURN
      END
