*     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
      IMPLICIT LOGICAL (A-Z,$)
************************************************************************
*                                                                      *
*                                                                      *
*        BUFFER FOR NAME RECORD FROM NAME TABLE FILE                   *
*                                                                      *
************************************************************************
************************************************************************
*                                                                      *
*                                                                      *
*        INPUT BUFFER AND I/O UNITS
*                                                                      *
************************************************************************
      INTEGER BUFFER , BUFFR2 ,INUNIT,OUNIT,TRMNAL,CODE,SUBCOD
      COMMON / OUTPUT / BUFFER(300) , BUFFR2(300),INUNIT,OUNIT,TRMNAL
      EQUIVALENCE (BUFFER(2),CODE),(BUFFER(3),SUBCOD)
      INTEGER
     . ARCODE , GRCODE , VSCODE , CICODE , ITCODE , IVCODE ,
     . STCODE , MMCODE , PSCODE , SBCODE , ISCODE , ALCODE
*                                                                      *
      COMMON / CODES /
     . ARCODE , GRCODE , VSCODE , CICODE , ITCODE , IVCODE ,
     . STCODE , MMCODE , PSCODE , SBCODE , ISCODE , ALCODE
************************************************************************
*        SCHEMA BEING CREATED
*
************************************************************************
      INTEGER CASIZE,CURARA(32),ERROR,CALIAS,CURREC
      COMMON / CURENT / CASIZE,CURARA,ERROR,CALIAS,CURREC
      INUNIT = 1
      OUNIT  = 2
      TRMNAL = 6
      CALIAS = 1
      CURREC = 0
      WRITE (TRMNAL,5)
5     FORMAT (' ERSP_2 A00 HERE')
      CALL NEXREC(BUFFER)
      CALL SCHDEF
1000  CONTINUE
      IF(CODE.EQ.ISCODE.AND.SUBCOD.EQ.0)  CALL NEXREC(BUFFER);GOTO1000
      IF(CODE.EQ.ARCODE.AND.SUBCOD.EQ.0)     CALL DMPARA;GO TO 1000
      IF(CODE.EQ.GRCODE.AND.SUBCOD.EQ.0)     CALL GRPDEF;GO TO 1000
      IF(CODE.EQ.GRCODE.AND.SUBCOD.EQ.ITCODE)CALL DMPITM;GO TO 1000
      IF(CODE.EQ.GRCODE.AND.SUBCOD.EQ.IVCODE)CALL INVERT;GO TO 1000
      IF(CODE.EQ.STCODE.AND.SUBCOD.EQ.0)     CALL SETDEF;GO TO 1000
      IF(CODE.EQ.STCODE.AND.SUBCOD.EQ.MMCODE)CALL MEMDEF;GO TO 1000
      IF(CODE.EQ.SBCODE.AND.SUBCOD.EQ.0)CALL NEXREC;GO TO 1000
      IF(CODE.EQ.GRCODE.AND.SUBCOD.EQ.CICODE)CALL NEXREC(BUFFER);
     .GO TO 1000
      WRITE(TRMNAL,1)CURREC,BUFFER
      STOP 'RECORD ORDER ERROR'
1     FORMAT(' RECORD OUR OF ORDER , #',G,//' CONTENTS ',10(
     .10(' ',Z8)))
      END
      BLOCK DATA
************************************************************************
*                                                                      *
*        GLOBAL CONSTANTS THROUGHOUT THE PROGRAM ARE                   *
*           1) CODES FOR THE OUTPUT RECORD  TYPES.                     *
*                                                                      *
************************************************************************
*                                                                      *
*        CODES FOR THE OUTPUT RECORD  TYPES                            *
*                                                                      *
*                                                                      *
************************************************************************
      INTEGER
     . ARCODE , GRCODE , VSCODE , CICODE , ITCODE , IVCODE ,
     . STCODE , MMCODE , PSCODE , SBCODE , ISCODE , ALCODE
*                                                                      *
      COMMON / CODES /
     . ARCODE , GRCODE , VSCODE , CICODE , ITCODE , IVCODE ,
     . STCODE , MMCODE , PSCODE , SBCODE , ISCODE , ALCODE
*                                                                      *
      DATA
     . ARCODE / 01 / , GRCODE / 02 / , STCODE / 03 / , SBCODE / 07 / ,
     . PSCODE / 08 / , MMCODE / 10 / , ISCODE / 10 / , VSCODE / 10 / ,
     . CICODE / 25 / , ITCODE / 30 / , IVCODE / 40 / , ALCODE / 10 /
      END
      SUBROUTINE OCCURS($OCCRS,$ISIZE,$TYPE,$PSIZE,$PICTR)
* MODIFLIED TO DENOTE IF PICTURE CONTAINS AN 'S' -- 4/81 -- JML HIS.
      IMPLICIT LOGICAL(A-Z,$)
      INTEGER CHAR9/ZF9000000/,CHARA/ZC1000000/,CHARX/ZE7000000/
      INTEGER CHAR0/ZF0000000/,CHARLB/Z4D000000/,CHARRB/Z5D000000/
      INTEGER CHARS/ZE2000000/
      INTEGER $OCCRS,$ISIZE,$TYPE,$PSIZE,$PICTR(30),$INDEX,$SIZE
     .,$MXPIC,$BSIZE,$TSIZE,$SIGN
*
*
*        FIRST TAKE CARE OF BINARY AND FLOATING ITEMS
*
*
      IF($TYPE.EQ.4)$OCCRS=$ISIZE/4;$ISIZE=4;RETURN
      IF($TYPE.EQ.5)$OCCRS=$ISIZE/4;$ISIZE=4;RETURN
      IF($TYPE.EQ.6)$OCCRS=$ISIZE/8;$ISIZE=8;RETURN
*
*
*
*
      $SIZE = 0
      $SIGN = 0
      IF($PSIZE.EQ.0)GO TO 999
      $INDEX = 0
99    CONTINUE
      $INDEX = $INDEX + 1
      IF($INDEX.GT.$PSIZE)GO TO 990
         IF($PICTR($INDEX).EQ.CHAR9.OR.
     .      $PICTR($INDEX).EQ.CHARA.OR.
     .      $PICTR($INDEX).EQ.CHARX)$SIZE=$SIZE+1
      IF($PICTR($INDEX).EQ.CHARS)$SIGN=1
      IF($PICTR($INDEX).NE.CHARLB)GO TO 99
      $BSIZE = 0
      $SIZE = $SIZE - 1
97    CONTINUE
      $INDEX = $INDEX + 1
      IF($PICTR($INDEX).EQ.CHARRB)GO TO 98
      IF($PICTR($INDEX).LE.CHAR9.AND.
     .   $PICTR($INDEX).GE.CHAR0)
     .$BSIZE = $BSIZE*10+ISL($PICTR($INDEX)-CHAR0,-24)
      GO TO 97
98    CONTINUE
      $SIZE = $SIZE + $BSIZE
      GO TO 99
990   CONTINUE
      IF($SIZE.EQ.0)GO TO 999
      IF($TYPE.NE.7)GO TO 997
      $TSIZE = $SIZE
      IF(MOD($SIZE,2).EQ.0)$SIZE=$SIZE+2;GO TO 996
      IF(MOD($SIZE,2).NE.0)$SIZE=$SIZE+1
      $SIZE = $SIZE / 2
996   $OCCRS = $ISIZE / $SIZE
      $ISIZE = $TSIZE
      RETURN
997   CONTINUE
      $OCCRS = $ISIZE / $SIZE
      $ISIZE = $SIZE
      RETURN
999   CONTINUE
      IF($TYPE.EQ.7)$MXPIC=16
      IF($TYPE.EQ.1.OR.
     .   $TYPE.EQ.3)$MXPIC=255
      IF($TYPE.EQ.0.OR.
     .   $TYPE.EQ.2)$MXPIC=31
      IF($ISIZE.LE.$MXPIC)$OCCRS=1;RETURN
9999  CONTINUE
      IF($MXPIC.LE.0)$OCCRS=1;RETURN
      IF(MOD($ISIZE,$MXPIC).NE.0)$MXPIC=$MXPIC-1;GO TO 9999
      $OCCRS = $ISIZE / $MXPIC
      IF($TYPE.NE.7)$ISIZE=$MXPIC;RETURN
      $ISIZE = $MXPIC * 2 - 1
      RETURN
      END
      SUBROUTINE DMPARA
************************************************************************
****                                                                ****
*****        SUBROUTINE DMPARA                                     *****
****                                                                ****
************************************************************************
************************************************************************
      IMPLICIT LOGICAL(A-Z,$)
************************************************************************
*                                                                      *
*        CODES FOR THE OUTPUT RECORD  TYPES                            *
*                                                                      *
*                                                                      *
************************************************************************
      INTEGER
     . ARCODE , GRCODE , VSCODE , CICODE , ITCODE , IVCODE ,
     . STCODE , MMCODE , PSCODE , SBCODE , ISCODE , ALCODE
*                                                                      *
      COMMON / CODES /
     . ARCODE , GRCODE , VSCODE , CICODE , ITCODE , IVCODE ,
     . STCODE , MMCODE , PSCODE , SBCODE , ISCODE , ALCODE
************************************************************************
*                                                                      *
*                                                                      *
*        INPUT BUFFER AND I/O UNITS
*                                                                      *
************************************************************************
      INTEGER BUFFER , BUFFR2 ,INUNIT,OUNIT,TRMNAL
*
************************************************************************
*        BLOCK CONTAINING CURENT PARAMETERS ABOUT THE
*        SCHEMA BEING CREATED
*
************************************************************************
      INTEGER CASIZE,CURARA(32),ERROR,CALIAS,CURREC
      COMMON / CURENT / CASIZE,CURARA,ERROR,CALIAS,CURREC
************************************************************************
*                                                                      *
*                                                                      *
*                                                                      *
*                                                                      *
*                                                                      *
*        LOCAL VARIABLES.                                              *
*        ================                                              *
*                                                                      *
*           $AREA  - CURENT AREA                                      *
*           $CODE  - CODE FOR AREA DEFINITION RECORD. (01)             *
*           $SBCOD - SUBCODE. ALWAYS ZERO FOR AREA DEF. RECORDS.       *
*           $WKINC - WORKING STORAGE INCREMENT                         *
*           $NPAGE - NUMBER OF PAGES IN AREA                           *
*           $AREAN - AREA NUMBER                                       *
*           $INVPC - INVENTORY PERCENT                                 *
*           $CHKSM - FLAG TO INDICATE IF AREA IS CHECKSUMMED           *
*           $DPLNN - NUMBER OF BITS IN LINE NUMBERS                    *
*           $CIPHR - FLAG TO INDICATE IF AREA IS ENCIPHERED            *
*           $JRNAL - FLAG TO INDICATE IF AREA IS JOURNALLED            *
*           $IKSIZ - NUMBER OF BYTES IN INDEX KEYS                     *
*           $PASIZ - PAGE SIZE IN WORDS                                *
*           $OVMIN - FIRST OVERFLOW PAGE FOR THE INDEXED GROUP DEFINED *
*                    IN THIS AREA.                                     *
*           $OVMAX - LAST OVERFLOW PAGE FOR THE INDEXED GROUP DEFINED  *
*                    FOR THIS AREA.                                    *
*           $NMCNT - NUMBER OF CHARACTERS IN AREA NAME                 *
*           $ARNAM - NAME IN "A1" FORMAT                               *
*           $TEMP  - LOCAL TEMP VARIABLE
*                                                                      *
************************************************************************
      INTEGER
     . $AREA  , $CODE  , $SBCOD , $WKINC , $NPAGE , $AREAN , $INVPC ,
     . $CHKSM , $DPLNN , $CIPHR , $JRNAL , $FLPCT , $IKSIZ , $PASIZ ,
     . $OVMIN , $OVMAX , $NMCNT , $ARNAM(32) , $TEMP , $LINES
*                                                                      *
      EQUIVALENCE
     .($AREA  , BUFFER( 1) ) ,
     .($CODE  , BUFFER( 2) ) ,
     .($SBCOD , BUFFER( 3) ) ,
     .($WKINC , BUFFER( 4) ) ,
     .($NPAGE , BUFFER( 5) ) ,
     .($AREAN , BUFFER( 6) ) ,
     .($INVPC , BUFFER( 7) ) ,
     .($CHKSM , BUFFER( 8) ) ,
     .($DPLNN , BUFFER( 9) ) ,
     .($CIPHR , BUFFER(10) ) ,
     .($JRNAL , BUFFER(11) ) ,
     .($FLPCT , BUFFER(12) ) ,
     .($IKSIZ , BUFFER(13) ) ,
     .($PASIZ , BUFFER(14) ) ,
     .($OVMIN , BUFFER(15) ) ,
     .($OVMAX , BUFFER(16) ) ,
     .($NMCNT , BUFFER(17) ) ,
     .($ARNAM , BUFFER(18) )
      INTEGER $DFALT (5,3)
      DATA $DFALT / 000001 , 065536 , 131072 , 262144 , 524228 ,
     .              065536 , 131072 , 262144 , 524228 , 1048575 ,
     .                   8 ,      7 ,      6 ,      5 ,       4 /
************************************************************************
*
*
*     WRITE OUT THE TEXT FOR THE RECORD DEFINITION
*
*
************************************************************************
      WRITE(OUNIT,1)$NMCNT,($ARNAM($TEMP),$TEMP=1,$NMCNT),$NPAGE
     .,$AREAN
      CASIZE=$NMCNT
      DO 99,$TEMP=1,$NMCNT
99    CURARA($TEMP)=$ARNAM($TEMP)
      IF($INVPC.NE.0)WRITE(OUNIT,2)$INVPC
      IF($CHKSM.EQ.0)WRITE(OUNIT,3)
      IF($JRNAL.EQ.1)WRITE(OUNIT,4)
      IF($CIPHR.EQ.1)WRITE(OUNIT,5)
      IF($OVMIN.NE.-1)WRITE(OUNIT,6)$OVMIN,$OVMAX
      IF($FLPCT.NE.0)WRITE(OUNIT,7)$FLPCT
      DO 999,$TEMP = 1,5
         IF($NPAGE.GE.$DFALT($TEMP,1).AND.
     .      $NPAGE.LE.$DFALT($TEMP,2).AND.
     .      $DPLNN.NE.$DFALT($TEMP,3))
     .      $LINES=2**$DPLNN-1;WRITE(OUNIT,8)$LINES
999   CONTINUE
      WRITE(OUNIT,9)
      CALL NEXREC(BUFFER)
      RETURN
1     FORMAT(' AREA NAME IS ',NA1,' CONTAINS ',G,'PAGES',
     ./,T6,' ; NUMBER IS ',G)
2     FORMAT(T6,' ; INVENTORY PERCENT IS ',G)
3     FORMAT(T6,' ; CHECKSUM IS NOT REQUIRED')
4     FORMAT(T6,' ; JOURNAL IS REQUIRED')
5     FORMAT(T6,' ; ENCIPHERING IS REQUIRED')
6     FORMAT(T6,' ; OVERFLOW RANGE IS PAGE ',G,'THRU PAGE ',G)
7     FORMAT(T6,' ; FILL PERCENT IS ',G)
8     FORMAT(T6,' ; LINES PER PAGE ARE ',G)
9     FORMAT(T6,'  .')
      END
      SUBROUTINE GRPDEF
************************************************************************
****                                                                ****
*****        SUBROUTINE GRPDEF                                     *****
****                                                                ****
************************************************************************
************************************************************************
      IMPLICIT LOGICAL(A-Z,$)
************************************************************************
*                                                                      *
*        CODES FOR THE OUTPUT RECORD TYPES                             *
*                                                                      *
************************************************************************
      INTEGER
     . ARCODE , GRCODE , VSCODE , CICODE , ITCODE , IVCODE ,
     . STCODE , MMCODE , PSCODE , SBCODE , ISCODE , ALCODE
*                                                                      *
      COMMON / CODES /
     . ARCODE , GRCODE , VSCODE , CICODE , ITCODE , IVCODE ,
     . STCODE , MMCODE , PSCODE , SBCODE , ISCODE , ALCODE
************************************************************************
*                                                                      *
*                                                                      *
*        INPUT BUFFER AND I/O UNITS
*                                                                      *
*                                                                      *
************************************************************************
      INTEGER BUFFER , BUFFR2 ,INUNIT,OUNIT,TRMNAL
      COMMON / OUTPUT / BUFFER(300) , BUFFR2(300),INUNIT,OUNIT,TRMNAL
************************************************************************
*        BLOCK CONTAINING CURENT PARAMETERS ABOUT THE
*        SCHEMA BEING CREATED
*
************************************************************************
      INTEGER CASIZE,CURARA(32),ERROR,CALIAS,CURREC
      COMMON / CURENT / CASIZE,CURARA,ERROR,CALIAS,CURREC
************************************************************************
*                                                                      *
*                                                                      *
*        LOCAL VARIABLES.                                              *
*        ================                                              *
*                                                                      *
*                                                                      *
*           $AREA  - CURENT AREA                                      *
*           $CODE  - CODE FOR GROUP DEFINITION RECORD (02)             *
*           $SBCOD - SUBCODE (ALWAYS ZERO)                             *
*           $GRPNM - GROUP NUMBER                                      *
*           $WKINC - WORKING STORAGE INCREMENT                         *
*           $STREL - FLAG TO INDICATE IF THIS GROUP IS RELATIVE TO A   *
*                    STORAGE SET.                                      *
*           $RTLOK - RETRIEVE LOCK                                     *
*           $UPLOK - UPDATE LOCK                                       *
*           $GRTYP  - GROUP TYPE :                                     *
*                    0) VIA SET                                        *
*                    1) DIRECT GROUP                                   *
*                    2) CALC GROUP                                     *
*                    3) INDEXED GROUP                                  *
*           $WSSIZ - WORKING STOREAGE SIZE IN WORDS                    *
*           $PGMIN - PAGE RANGE MINIMUM (0 IF NOT PRESENT)             *
*           $PGMAX - PAGE RANGE MAXIMUM (0 IF NOT PRESENT)             *
*           $PGPRM - PAGE RANGE PRIME VALUE (0 IF NOT PRESENT)        **
*           $CNREC - NUMBER OF CONTROL ITEMS FOR THIS GROUP            *
*           $BYTES - NUMBER OF DATA BYTES IN GROUP                     *
*           $MANUL - FLAG TO INDICATE IF THIS IS A MANUAL MEMBER OF    *
*                    A SET                                             *
*           $STATS - FLAG TO INDICATE IF STATISTICS ARE GENERATED FOR  *
*                    THIS GROUP                                        *
*           $NSIZE - NUMBER OF CHARACTERS IN NAME                      *
*           $GNAME - NAME                                              *
*           $SETCT - NUMBER OF SETS THIS GROUP PARTICIPATES IN         *
*           $SETS  - ARRAY OF THE SET NUMBERS IT PARTICIPATES IN       *
*           $INDEX - SCRATCH VARIABLE
*           $SETPT - SCRATCH VARIABLE
*                                                                      *
************************************************************************
      INTEGER
     . $GRPNM , $WKINC , $STREL , $RTLOK , $UPLOK , $STATS , $GRTYP ,
     . $DBGSZ , $WSSIZ , $PGMIN , $PGMAX , $PGPRM , $CNREC , $BYTES ,
     . $NSIZE,$GNAME(32), $INSIZ,$INAME(32), $AREA , $CODE ,
     . $SBCOD , $MANUL  , $INDEX  , $SNSIZ,$SNAME(32),
     .$IND2 , $DUPE , $TEMP
*                                                                      *
      EQUIVALENCE
     .($AREA  , BUFFER( 1) ) ,
     .($CODE  , BUFFER( 2) ) ,
     .($SBCOD , BUFFER( 3) ) ,
     .($GRPNM , BUFFER( 4) ) ,
     .($WKINC , BUFFER( 5) ) ,
     .($STREL , BUFFER( 6) ) ,
     .($RTLOK , BUFFER( 7) )
      EQUIVALENCE
     .($UPLOK , BUFFER( 8) ) ,
     .($GRTYP , BUFFER( 9) ) ,
     .($DBGSZ , BUFFER(10) ) ,
     .($WSSIZ , BUFFER(11) ) ,
     .($PGMIN , BUFFER(12) ) ,
     .($PGMAX , BUFFER(13) ) ,
     .($PGPRM , BUFFER(14) ) ,
     .($CNREC , BUFFER(15) ) ,
     .($BYTES , BUFFER(16) ) ,
     .($MANUL , BUFFER(17) ) ,
     .($STATS , BUFFER(18) ) ,
     .($DUPE  , BUFFER(19) ) ,
     .($NSIZE , BUFFER(20) ) ,
     .($GNAME , BUFFER(21) )
      EQUIVALENCE
     .( $INSIZ , BUFFR2(13) ),
     .( $INAME , BUFFR2(14) ),
     .( $SNSIZ , BUFFR2(5)  ),
     .( $SNAME , BUFFR2(6)  )
      $TEMP = $GRPNM
10100 CONTINUE
*     GET THE AREA NAME
      CALL MAKEKEY(2,$AREA,1,0,CSGPKEY)
      READ (INUNIT,'(300A4)',KEY=CSGPKEY) BUFFR2
      CASIZE=BUFFR2(17)
      DO 2000,$INDEX=18,17+CASIZE
2000  CURARA($INDEX-17)=BUFFR2($INDEX)
*     NOW GET BACK WHERE WE WERE!
      CALL MAKEKEY(3,$GRPNM,1,0,CSGPKEY)
      READ (INUNIT,'(300A4)',KEY=CSGPKEY) BUFFR2
      IF($NSIZE.NE.0)GO TO 10101
*     MAKE UP NAME FOR AREA IS OWNER GROUP
      WRITE (OUNIT,18)CASIZE,(CURARA($INDEX),$INDEX=1,CASIZE)
18    FORMAT('  GROUP NAME IS AREA',NA1)
      GOTO 10102
*
*
*        WRITE OUT GROUP AND AREA NAME
*
*
10101 CONTINUE
      WRITE(OUNIT,1)$NSIZE,($GNAME($INDEX),$INDEX=1,$NSIZE)
10102 WRITE(OUNIT,2)CASIZE,(CURARA($INDEX),$INDEX=1,CASIZE)
      IF($PGMIN.NE.-1)WRITE(OUNIT,3)$PGMIN,$PGMAX
*
*
*        WRITE OUT LOCATION MODE
*
*
      $INDEX = $GRTYP+1
100    CONTINUE
*
*
*        DIRECT GROUP
*
*
      WRITE(OUNIT,4)
      IF($STREL.EQ.0)GO TO 50
      CALL NEXREC(BUFFR2)
      WRITE(OUNIT,5)$SNSIZ,($SNAME($INDEX),$INDEX=1,$SNSIZ)
      GO TO 50
200    CONTINUE
*
*
*        INDEXED GROUP
*
*
      CHARACTER*16 CSGPKEY
      INTEGER CLIST(30),NCLST,$IXN
      CALL MAKEKEY(3,$GRPNM,4,0,CSGPKEY)
      NCLST=0
      READ (INUNIT,'(300A4)',KEY=CSGPKEY) BUFFR2
      DO 21, $INDEX=6,(BUFFR2(5)*4+6),4
      IF(BUFFR2($INDEX).NE.2)GO TO 21
      CLIST(BUFFR2($INDEX+2))=BUFFR2($INDEX+1)
      NCLST=NCLST+1
21    NCLST=NCLST
      CALL MAKEKEY(3,$GRPNM,5,CLIST(1),CSGPKEY)
      READ (INUNIT,'(300A4)',KEY=CSGPKEY) BUFFR2
      WRITE(OUNIT,6)$INSIZ,($INAME($INDEX),$INDEX=1,$INSIZ)
      IF(NCLST.EQ.1)GO TO 50
      DO 22, $INDEX=2,NCLST
      CALL MAKEKEY(3,$GRPNM,5,CLIST($INDEX),CSGPKEY)
      READ (INUNIT,'(300A4)',KEY=CSGPKEY) BUFFR2
      WRITE(OUNIT,7)$INSIZ,($INAME($IXN),$IXN=1,$INSIZ)
22    CONTINUE
      CALL MAKEKEY(3,$GRPNM,4,0,CSGPKEY)
      READ (INUNIT,'(300A4)',KEY=CSGPKEY) BUFFR2
*      GET BACK TO CONTROL DEF RECORD
      GO TO 50
300    CONTINUE
*
*
*
*        CALC GROUP
*
*
*
      CALL MAKEKEY(3,$GRPNM,4,0,CSGPKEY)
      NCLST=0
      READ (INUNIT,'(300A4)',KEY=CSGPKEY) BUFFR2
      DO 31, $INDEX=6,(BUFFR2(5)*4+6),4
      IF(BUFFR2($INDEX).NE.2)GO TO 31
      CLIST(BUFFR2($INDEX+2))=BUFFR2($INDEX+1)
      NCLST=NCLST+1
31    CONTINUE
      CALL MAKEKEY(3,$GRPNM,5,CLIST(1),CSGPKEY)
      WRITE(OUNIT,8)$INSIZ,($INAME($INDEX),$INDEX=1,$INSIZ)
      IF(NCLST.EQ.1)GO TO 33
      DO 32, $INDEX=2,NCLST
      CALL MAKEKEY(3,$GRPNM,5,CLIST($INDEX),CSGPKEY)
      READ (INUNIT,'(300A4)',KEY=CSGPKEY) BUFFR2
      WRITE(OUNIT,7)$INSIZ,($INAME($IXN),$IXN=1,$INSIZ)
32    CONTINUE
33    CALL MAKEKEY(3,$GRPNM,4,0,CSGPKEY)
      READ (INUNIT,'(300A4)',KEY=CSGPKEY) BUFFR2
*      GET BACK TO CONTROL DEF RECORD
      IF($DUPE.EQ.0)WRITE(OUNIT,9);GO TO 50
      WRITE(OUNIT,10)
      GO TO 50
400    CONTINUE
*
*
*        VIA SET
*
*
      CALL NEXREC(BUFFR2)
      WRITE(OUNIT,11)$SNSIZ,($SNAME($INDEX),$INDEX=1,$SNSIZ)
      CALL NEXREC(BUFFR2)
      IF(BUFFR2(3).NE.VSCODE+1)GO TO 50
      WRITE(OUNIT,5)$SNSIZ,($SNAME($INDEX),$INDEX=1,$SNSIZ)
50    CONTINUE
*
*
*        NOW WRITE OUT GROUP NUMBER AND WHETHER OR NOT
*        STATS ARE REQUIRED, AS WELL AS THE RETRIEVE AND UPDATE
*        KEYS
*
*
      IF($GRPNM.GE.1000)WRITE(OUNIT,13) $GRPNM-100;GO TO 52
      WRITE(OUNIT,13)$GRPNM
52    CONTINUE
      IF($RTLOK.NE.0)WRITE(OUNIT,14),$RTLOK
      IF($UPLOK.NE.0)WRITE(OUNIT,15),$UPLOK
      IF($STATS.NE.0)WRITE(OUNIT,16)
      WRITE(OUNIT,17)
      IF($SBCOD.NE.ITCODE)CALL NEXREC(BUFFER)
      RETURN
1     FORMAT(  '  GROUP NAME IS ',NA1)
2     FORMAT(T06,' ; WITHIN ',NA1)
3     FORMAT(T12,', RANGE IS PAGE ',G,' THRU PAGE ',G)
4     FORMAT(T06,' ; LOCATION MODE IS DIRECT ')
5     FORMAT(T12,', STORAGE IS ',NA1,' SET')
6     FORMAT(T06,' ; LOCATION MODE IS INDEXED USING ',NA1)
7     FORMAT(T37,' , ',NA1)
8     FORMAT(T06,' ; LOCATION MODE IS CALC USING    ',NA1)
10    FORMAT(T12,'   DUPLICATES ARE ALLOWED')
11    FORMAT(T06,' ; LOCATION MODE IS VIA ',NA1,' SET ')
13    FORMAT(T06,' ; NUMBER IS ',G)
14    FORMAT(T06,' ; PRIVACY LOCK FOR RETRIEVE IS ',G)
15    FORMAT(T06,' ; PRIVACY LOCK FOR UPDATE  IS  ',G)
16    FORMAT(T06,' ; STATISTICS ARE REQUIRED')
17    FORMAT(T06,' .')
      END
      SUBROUTINE INVERT
************************************************************************
************************************************************************
****                                                                ****
*****        SUBROUTINE INVERT                                     *****
****                                                                ****
************************************************************************
************************************************************************
      IMPLICIT LOGICAL(A-Z,$)
************************************************************************
*                                                                      *
*                                                                      *
*        CODES FOR THE OUTPUT RECORD  TYPES                            *
*                                                                      *
************************************************************************
      INTEGER
     . ARCODE , GRCODE , VSCODE , CICODE , ITCODE , IVCODE ,
     . STCODE , MMCODE , PSCODE , SBCODE , ISCODE , ALCODE
*                                                                      *
      COMMON / CODES /
     . ARCODE , GRCODE , VSCODE , CICODE , ITCODE , IVCODE ,
     . STCODE , MMCODE , PSCODE , SBCODE , ISCODE , ALCODE
************************************************************************
*        BLOCK CONTAINING CURENT PARAMETERS ABOUT THE
*        SCHEMA BEING CREATED
*
************************************************************************
      INTEGER CASIZE,CURARA(32),ERROR,CALIAS,CURREC
      COMMON / CURENT / CASIZE,CURARA,ERROR,CALIAS,CURREC
************************************************************************
*                                                                      *
*                                                                      *
*        INPUT BUFFER AND I/O UNITS
*                                                                      *
*                                                                      *
************************************************************************
      INTEGER BUFFER , BUFFR2 ,INUNIT,OUNIT,TRMNAL
      COMMON / OUTPUT / BUFFER(300) , BUFFR2(300),INUNIT,OUNIT,TRMNAL
************************************************************************
*                                                                      *
*                                                                      *
*                                                                      *
*                                                                      *
*        LOCAL VARIABLES                                               *
*        ===============                                               *
*                                                                      *
*     $AREA  - CURENT AREA                                            *
*     $CODE  - CODE FOR GROUP DEFINITION                               *
*     $SBCOD - CODE FOR INVERT ITEM DEFINITION (40)                    *
*     $IVGRP      - INVERT GROUP NUMBER                                *
*     $PGMIN      - PAGE RANGE MINIMUM                                 *
*     $PGPRI      - PAGE RANGE PRIME VALUE                             *
*     $DUPE       - 1 IF DUPLICATES ALLOWED                            *
*     $NSIZE      - SIZE OF NAME                                       *
*     $NAME       - NAME IN 'A1' FORMAT                                *
*     $IVPTR - POINTER AT INVERT DEFINITION                            *
*     $TEMP  - LOCAL SCRATCH VARIABLE                                  *
*                                                                      *
*                                                                      *
************************************************************************
      INTEGER
     . $IVGRP , $PGMIN , $PGMAX , $PGPRI , $DUPE  , $NSIZE , $AREA ,
     . $NAME(32) , $CODE , $SBCOD  , $INDEX  , $SGRP
      EQUIVALENCE
     .( $AREA    , BUFFER( 1) ) ,
     .( $CODE    , BUFFER( 2) ) ,
     .( $SBCOD   , BUFFER( 3) ) ,
     .( $SGRP   , BUFFER( 4)) ,
     .( $IVGRP   , BUFFER( 5) ) ,
     .( $PGMIN   , BUFFER( 6) ) ,
     .( $PGMAX   , BUFFER( 7) ) ,
     .( $PGPRI   , BUFFER( 8) ) ,
     .( $DUPE    , BUFFER( 9) ) ,
     .( $NSIZE   , BUFFER(10) ) ,
     .( $NAME    , BUFFER(11) )
      WRITE(OUNIT,1)$NSIZE,($NAME($INDEX),$INDEX=1,$NSIZE)
      WRITE(OUNIT,2)$IVGRP
      CHARACTER*16 CSGPKEY
*     GET THE RIGHT AREA FOR THIS INVERT GROUP
*     GET THE AREA NAME
      CALL MAKEKEY(2,$AREA,1,0,CSGPKEY)
      READ (INUNIT,'(300A4)',KEY=CSGPKEY) BUFFR2
      CASIZE=BUFFR2(17)
      DO 2000,$INDEX=18,17+CASIZE
2000  CURARA($INDEX-17)=BUFFR2($INDEX)
*     NOW GET BACK WHERE WE WERE!
      CALL MAKEKEY(3,$SGRP,7,$IVGRP,CSGPKEY)
      WRITE(OUNIT,3)CASIZE,(CURARA($INDEX),$INDEX=1,CASIZE)
      IF($PGMIN.NE.-1)WRITE(OUNIT,4)$PGMIN,$PGMAX
      IF($DUPE.EQ.0)WRITE(OUNIT,5);WRITE(OUNIT,7);GO TO 8
      WRITE(OUNIT,6)
      WRITE(OUNIT,7)
8     CALL NEXREC(BUFFER)
      RETURN
1     FORMAT(T6,' INVERT ON ',NA1)
2     FORMAT(T12,' ; NUMBER IS ',G)
3     FORMAT(T12,' ; WITHIN ',NA1)
4     FORMAT(T18,' RANGE IS PAGE ',G,' THRU PAGE ',G)
5     FORMAT(T12,' ; DUPLICATES ARE NOT ALLOWED')
6     FORMAT(T12,' ; DUPLICATES ARE ALLOWED')
7     FORMAT(T12,' .')
      END
      SUBROUTINE DMPITM
************************************************************************
************************************************************************
****                                                                ****
*****        SUBROUTINE DMPITM                                     *****
****                                                                ****
************************************************************************
************************************************************************
      IMPLICIT LOGICAL(A-Z,$)
************************************************************************
*                                                                      *
*                                                                      *
*        CODES FOR THE OUTPUT RECORD  TYPES                            *
*                                                                      *
************************************************************************
      INTEGER
     . ARCODE , GRCODE , VSCODE , CICODE , ITCODE , IVCODE ,
     . STCODE , MMCODE , PSCODE , SBCODE , ISCODE , ALCODE
      COMMON / CODES /
     . ARCODE , GRCODE , VSCODE , CICODE , ITCODE , IVCODE ,
     . STCODE , MMCODE , PSCODE , SBCODE , ISCODE , ALCODE
************************************************************************
*                                                                      *
*                                                                      *
*        INPUT BUFFER AND I/O UNITS
*                                                                      *
************************************************************************
      INTEGER BUFFER , BUFFR2 ,INUNIT,OUNIT,TRMNAL
      COMMON / OUTPUT / BUFFER(300) , BUFFR2(300),INUNIT,OUNIT,TRMNAL
************************************************************************
*        BLOCK CONTAINING CURENT PARAMETERS ABOUT THE
*        SCHEMA BEING CREATED
*
************************************************************************
      INTEGER CASIZE,CURARA(32),ERROR,CALIAS,CURREC
      COMMON / CURENT / CASIZE,CURARA,ERROR,CALIAS,CURREC
************************************************************************
*                                                                      *
*                                                                      *
*                                                                      *
*                                                                      *
*        LOCAL VARIABLES                                               *
*        ===============                                               *
*                                                                      *
*     $AREA  - CURENT AREA                                            *
*     $CODE  - CODE FOR GROUP DEFINITION ( 02 )                        *
*     $GRNUM - GROUP NUMBER ASSOCIATED WITH THIS ITEM                  *
*     $CONT    - 1 IF THIS IS A CONTROL ITEM                           *
*     $TYPE    - ITEM TYPE :                                           *
*                 0 -> SIGNED NUMBER                                   *
*                 1 -> ALPHANUMERIC                                    *
*                 2 -> NUMERIC                                         *
*                 3 -> ALPHABETIC                                      *
*                 4 -> BINARY                                          *
*                 6 -> FLOATING LONG                                   *
*                 7 -> PACKED DECIMAL                                  *
*     $INVRT   - 1 IF ITEM IS INVERTED                                 *
*     $WSINC   - WORKING STORAGE INCREMENT OF ITEM                     *
*     $ISIZE   - ITEM SIZE IN BYTES                                    *
*     $FINC    - FILE INCREMENT OF ITEM                                *
*     $RTLOC   - RETRIEVE LOCK FOR ITEM                                *
*     $UPLOC   - UPDATE LOCK FOR ITEM                                  *
*     $NSIZE   - NAME SIZE                                             *
*     $NAME    - NAME IN 'A1' FORMAT                                   *
*     $TIMES - SCRATCH VARIABLE                                        *
*     $LINKN - SCRATCH VARIABLE                                        *
*     $LINKH - SCRATCH VARIABLE                                        *
*     $CIND  - SCRATCH VARIABLE                                        *
*     $INDEX - SCRATCH VARIABLE                                        *
*     $ITEND - SCRATCH VARIABLE                                        *
*                                                                      *
      INTEGER RSPBUF(80)
      INTEGER
     . $CONT  , $TYPE  , $INVRT , $WSINC , $FINC  , $AREA  , $CODE  ,
     . $RTLOC , $UPLOC , $NSIZE   , $INDEX , $GRNUM
     . ,$ISIZE  , $SBCOD  , $IND2 , $LT2ST , $LITEN
     .,$NAME(32) , $OCCRS , $PSIZE , $PSTRT , $PEND , OCCURS , $LT2SZ
     .,$CHECK , $CHKPT , $CHKSZ  , $LITSZ
*                                                                      *
*                                                                      *
*                                                                      *
      EQUIVALENCE
     .( $AREA  , BUFFER( 1) ) ,
     .( $CODE  , BUFFER( 2) ) ,
     .( $GRNUM , BUFFER( 4) ) ,
     .( $SBCOD , BUFFER( 3) ) ,
     .( $CONT  , BUFFER( 5) ) ,
     .( $TYPE  , BUFFER( 6) ) ,
     .( $INVRT , BUFFER( 7) ) ,
     .( $WSINC , BUFFER( 8) ) ,
     .( $ISIZE , BUFFER( 9) ) ,
     .( $FINC  , BUFFER(10) ) ,
     .( $RTLOC , BUFFER(11) ) ,
     .( $UPLOC , BUFFER(12) ) ,
     .( $NSIZE , BUFFER(13) ) ,
     .( $NAME  , BUFFER(14) )
      WRITE(OUNIT,1)$NSIZE,($NAME($INDEX),$INDEX =1,$NSIZE)
      $PEND = $NSIZE + 14
* THE ABOVE LINE ALLOWS BINARY & FLT POINT #S TO BE CONVERTED CORRECTLY
      $OCCRS = 0
      $INDEX = $TYPE+1
      GOTO (90,90,90,90,20,20,20,90),$INDEX
90    CONTINUE
      $PSIZE = BUFFER($NSIZE + 14)
      $PSTRT = $NSIZE + 15
      $PEND  = $PSTRT + $PSIZE - 1
      IF($PSIZE.NE.0)WRITE(OUNIT,2)$PSIZE,(BUFFER($IND2),$IND2 = $PSTRT
     .,$PEND)
      CALL OCCURS($OCCRS,$ISIZE,$TYPE,$PSIZE,BUFFER($PSTRT))
20    GOTO(40,40,40,40,50,60,70,80),$INDEX
40    CONTINUE
      WRITE(OUNIT,3)$ISIZE; GO TO 100
50    WRITE(OUNIT,4);GO TO 100
70    WRITE(OUNIT,6);GO TO 100
80    WRITE(OUNIT,7)$ISIZE
100   CONTINUE
      IF($OCCRS.LE.1)GOTO 101
      CALL MAKEKEY(3,$GRNUM,5,$FINC,RSPKEY)
      WRITE (OUNIT,8)$OCCRS
      READ (7,'(80A4)',KEY=RSPKEY) RSPBUF
      RSPBUF(7)=$OCCRS;RSPBUF(17)=$ISIZE
*      PUT # IN INVERT AND UPDATE ITGSIZ!
      WRITE (7,'(80A4)',KEY=RSPKEY) RSPBUF
101   CONTINUE
      IF($RTLOC.NE.0)WRITE(OUNIT,9)$RTLOC
      IF($UPLOC.NE.0)WRITE(OUNIT,10)$UPLOC
      $CHKPT = $PEND + 3
1000  CONTINUE
      $CHKSZ = BUFFER($CHKPT-2)
      IF($CHKSZ.EQ.0)WRITE(OUNIT,13);CALL NEXREC(BUFFER);RETURN
      $CHECK = BUFFER($CHKPT-1)
      IF($CHECK.EQ.0)GO TO 2000
      $LITSZ = $CHKSZ / 2
      $LITEN = $CHKPT + $LITSZ - 1
      $LT2ST = $LITEN + 1
      $LT2SZ = $LT2ST + $LITSZ - 1
      WRITE(OUNIT,11)$LITSZ,(BUFFER($INDEX),$INDEX=$CHKPT,$LITEN)
     .,$LITSZ,(BUFFER($INDEX),$INDEX =$LT2ST,$LT2SZ)
      GO TO 3000
2000  CONTINUE
      WRITE(OUNIT,12)
3000  CONTINUE
      $CHKPT = $CHKPT + $CHKSZ + 2
      GO TO 1000
1     FORMAT(T6,NA1)
2     FORMAT(T12,' ; PICTURE IS ',NA1)
3     FORMAT(T12,' ; TYPE IS CHARACTER,',G)
4     FORMAT(T12,' ; TYPE IS BINARY')
5     FORMAT(T12,' ; TYPE IS FLOATING SHORT')
6     FORMAT(T12,' ; TYPE IS FLOATING LONG')
7     FORMAT(T12,' ; TYPE IS PACKED DECIMAL , ',G)
8     FORMAT(T12,' ; OCCURS ',G,' TIMES ')
9     FORMAT(T12,' ; PRIVACY LOCK FOR RETRIEVE IS ',G)
10    FORMAT(T12,' ; PRIVACY LOCK FOR UPDATE IS ',G)
11    FORMAT(T18,' ; CHECK IS RANGE OF ''' ,NA4,'''',/
     .T34,'THRU ''',NA4,'''')
12    FORMAT(T18,' ; CHECK IS PICTURE')
13    FORMAT(T12,' .')
      END
      SUBROUTINE MEMDEF
************************************************************************
************************************************************************
****                                                                ****
*****        SUBROUTINE MEMDEF                                     *****
****                                                                ****
************************************************************************
************************************************************************
      IMPLICIT LOGICAL(A-Z,$)
************************************************************************
*                                                                      *
*                                                                      *
*        CODES FOR THE OUTPUT RECORD  TYPES                            *
*                                                                      *
************************************************************************
      INTEGER
     . ARCODE , GRCODE , VSCODE , CICODE , ITCODE , IVCODE ,
     . STCODE , MMCODE , PSCODE , SBCODE , ISCODE , ALCODE
*                                                                      *
      COMMON / CODES /
     . ARCODE , GRCODE , VSCODE , CICODE , ITCODE , IVCODE ,
     . STCODE , MMCODE , PSCODE , SBCODE , ISCODE , ALCODE
************************************************************************
*                                                                      *
*                                                                      *
*        INPUT BUFFER AND I/O UNITS
*                                                                      *
************************************************************************
      INTEGER BUFFER , BUFFR2 ,INUNIT,OUNIT,TRMNAL
************************************************************************
*        BLOCK CONTAINING CURENT PARAMETERS ABOUT THE
*        SCHEMA BEING CREATED
*
************************************************************************
      INTEGER CASIZE,CURARA(32),ERROR,CALIAS,CURREC
      COMMON / CURENT / CASIZE,CURARA,ERROR,CALIAS,CURREC
************************************************************************
*                                                                      *
*                                                                      *
*                                                                      *
*                                                                      *
*        LOCAL VARIABLES                                               *
*        ===============                                               *
*                                                                      *
*                                                                      *
*     $AREA  - CURENT AREA                                            *
*     $CODE  - CODE FOR SET DEFINITIONS                                *
*     $SBCOD - CODE FOR MEMBER DEFINITIONS (10)                        *
*     $SETN    - SET NUMBER THIS MEMBER BELONGS TO                     *
*     $PNEXT   - POSITION OF NEXT POINTER FOR THIS MEMBER              *
*     $PRIOR   - POSITION OF PRIOR POINTER FOR THIS MEMBER             *
*     $PHEAD   - POSITION OF HEAD POINTER FOR THIS MEMBER              *
*     $ALIAS   - 1 IF THERE IS AN ALIAS FOR THIS SET, 0 IF NOT         *
*     $OPTON   - 1 IF THIS IS AN OPTIONAL MEMBER OF THE SET            *
*     $MANUL   - 1 IF THIS S A MANUAL MEMBER OF THE SET                *
*     $PSET    - 1 IF THIS IS A PAGESET MEMBER                         *
*     $CSET    - 1 IF THIS IS A CALCSET MEMBER                         *
*     $SORT    - 1 IF GROUP NUMBER IS MAJOR SORT KEY, 2 IF MINOR       *
*     $ORDER   - 0 -> LAST                                             *
*                1 -> PRIOR                                            *
*                4 -> SORTED                                           *
*                8 -> FIRST                                            *
*                9 -> NEXT                                             *
*                6 -> SORTED BY GROUP NUMBER                           *
*     $DUPE    - 0 IMPLIES DUPLICATES NOT ALLOWED                      *
*              - 1 IMPLIES DUPLICATES FIRST                            *
*              - 2 IMPLIES DUPLICATES LAST                             *
*     $SELEC   - 0 IMPLIES LOCATION MODE OF OWNER                      *
*              - 1 IMPLIES SELECTION IS CURENT                        *
*     $STSET   - 1 IF THIS IS THE STORAGE SET FOR A GROUP              *
*     $STGRP   - GROUP NUMBER IT IS STORAGE SET FOR                    *
*     $PRIME   - 1 IF THIS IS A PRIME RETRIEVAL SET                    *
*     $CONT    - 1 IF CONTROL ITEMS HAVE BEEN OMMITTED                 *
*     $NSIZE - COUNT OF CHARACTERS IN GROUP NAME                       *
*     $NAME  - OWNER  GROUP NAME                                       *
*                                                                      *
*                                                                      *
************************************************************************
      INTEGER  $SETN  , $PNEXT , $PRIOR , $PHEAD , $ALIAS , $OPTON
     .,        $MANUL , $PSET  , $CSET  , $SORT  , $ORDER , $ALIAC
     .,        $DUPE  , $SELEC , $STSET , $STGRP , $PRIME , $CONT
     .,         $SBCOD , $NSIZE , $NAME(32)  , $START , $END,$IND3
      EQUIVALENCE
     .( $AREA  , BUFFER( 1) ) ,
     .( $CODE  , BUFFER( 2) ) ,
     .( $SBCOD , BUFFER( 3) ) ,
     .( $SETN  , BUFFER( 4) ) ,
     .( $GRPNM , BUFFER( 5) ) ,
     .( $PNEXT , BUFFER( 6) ) ,
     .( $PRIOR , BUFFER( 7) ) ,
     .( $PHEAD , BUFFER( 8) ) ,
     .( $ALIAS , BUFFER( 9) ) ,
     .( $OPTON , BUFFER(10) )
      EQUIVALENCE
     .( $MANUL , BUFFER(11) ) ,
     .( $PSET  , BUFFER(12) ) ,
     .( $CSET  , BUFFER(13) ) ,
     .( $SORT  , BUFFER(14) ) ,
     .( $ORDER , BUFFER(15) ) ,
     .( $DUPE  , BUFFER(16) ) ,
     .( $SELEC , BUFFER(17) ) ,
     .( $STSET , BUFFER(18) ) ,
     .( $STGRP , BUFFER(19) ) ,
     .( $PRIME , BUFFER(20) ) ,
     .( $CONT  , BUFFER(21) ) ,
     .( $ALIAC , BUFFER(22) ) ,
     .( $NSIZE , BUFFER(23) ) ,
     .( $NAME  , BUFFER(24) )
      WRITE(OUNIT,1)$NSIZE,($NAME($INDEX),$INDEX=1,$NSIZE)
      IF($OPTON.NE.0)WRITE(OUNIT,2);GO TO 100
      IF($MANUL.NE.0)WRITE(OUNIT,3);GO TO 100
      WRITE(OUNIT,4)
100    CONTINUE
      IF($PHEAD.NE.0)WRITE(OUNIT,5)
      IF($SELEC.NE.0)WRITE(OUNIT,6);GO TO 20
      IF($ALIAC.EQ.0)WRITE(OUNIT,7);GO TO 20
      DO 110,$INDEX = 1,$ALIAC
         CALL NEXREC(BUFFR2)
         WRITE(OUNIT,8)$NSIZE,($NAME($IND2),$IND2=1,$NSIZE),CALIAS
         CALIAS = CALIAS + 1
110    CONTINUE
20    CONTINUE
      $INDEX = 24 + $NSIZE
      $IND2 = BUFFER($INDEX)
      IF($IND2.EQ.0)GO TO 40
      WRITE(OUNIT,9)
      $INDEX = $INDEX + 1
      DO 21,$TEMP  = 1,$IND2
      $START = $INDEX + 1
      $END   = $START + BUFFER($START)
     .,$END)
      IF(BUFFER($INDEX).EQ.6)WRITE(OUNIT,11)(BUFFER($IND3),$IND3=$START
     .,$END)
         $INDEX = $INDEX + 2 + BUFFER($START)
21    CONTINUE
30    CONTINUE
      IF($DUPE.EQ.0)WRITE(OUNIT,12);GO TO 40
      IF($DUPE.EQ.1)WRITE(OUNIT,13);GO TO 40
      IF($DUPE.EQ.2)WRITE(OUNIT,14)
40    CONTINUE
      WRITE(OUNIT,15)
      CALL NEXREC(BUFFER)
      RETURN
1     FORMAT(T6,'MEMBER IS ',NA1)
2     FORMAT(T12,' ; INCLUSION IS OPTIONAL AUTOMATIC')
3     FORMAT(T12,' ; INCLUSION IS MANUAL')
4     FORMAT(T12,' ; INCLUSION IS AUTOMATIC')
5     FORMAT(T12,' ; LINKED TO OWNER')
6     FORMAT(T12,' ; SET OCCURRENCE SELECTION IS THRU CURRENT OF SET')
7     FORMAT(T12,' ; SET OCCURRENCE SELECTION IS THRU LOCATION MODE',
     .' OF OWNER')
8     FORMAT(T18,' ALIAS FOR ',NA1,' IS RESTRUCTURED-DDL-ALIAS-',G)
9     FORMAT(T12,' ;')
10    FORMAT(T12,'ASCENDING KEY IS ',NA1)
11    FORMAT(T12,'DESCENDING KEY IS ',NA1)
12    FORMAT(T18,'DUPLICATES NOT ALLOWED')
13    FORMAT(T18,'DUPLICATES FIRST')
14    FORMAT(T18,'DUPLICATES LAST')
15    FORMAT(T12,' .')
      END
      SUBROUTINE SETDEF
************************************************************************
************************************************************************
****                                                                ****
*****        SUBROUTINE SETDEF                                     *****
****                                                                ****RR928
************************************************************************
************************************************************************
      IMPLICIT LOGICAL(A-Z,$)
************************************************************************
*                                                                      *
*                                                                      *
*        CODES FOR THE OUTPUT RECORD  TYPES                            *
*                                                                      *
************************************************************************
      INTEGER
     . ARCODE , GRCODE , VSCODE , CICODE , ITCODE , IVCODE ,
     . STCODE , MMCODE , PSCODE , SBCODE , ISCODE , ALCODE
*                                                                      *
      COMMON / CODES /
     . ARCODE , GRCODE , VSCODE , CICODE , ITCODE , IVCODE ,
     . STCODE , MMCODE , PSCODE , SBCODE , ISCODE , ALCODE
************************************************************************
*        BLOCK CONTAINING CURENT PARAMETERS ABOUT THE
*        SCHEMA BEING CREATED
*
************************************************************************
      INTEGER CASIZE,CURARA(32),ERROR,CALIAS,CURREC
      COMMON / CURENT / CASIZE,CURARA,ERROR,CALIAS,CURREC
************************************************************************
*                                                                      *
*                                                                      *
*        INPUT BUFFER AND I/O UNITS
*                                                                      *
************************************************************************
      INTEGER BUFFER , BUFFR2 ,INUNIT,OUNIT,TRMNAL
      COMMON / OUTPUT / BUFFER(300) , BUFFR2(300),INUNIT,OUNIT,TRMNAL
************************************************************************
*                                                                      *
*                                                                      *
*        LOCAL VARIABLES                                               *
*                                                                      *
*                                                                      *
*     $AREA  - CURENT AREA                                            *
*     $CODE  - CODE FOR SET DEFINITION (03)                            *
*     $SBCOD - SUBCODE (ALWAYS ZERO)                                   *
*     $SETN    - NUMBER OF THE SET DEFINED BY THIS OWNER DEFN.         *
*     $OGRP    - NUMBER OF THE OWNER GROUP FOR THIS SET                *
*     $PNEXT   - POSITION OF NEXT POINTER FOR THIS SET                 *
*     $PRIOR   - POSITION OF PRIOR POINTER FOR THIS SET                *
*     $NSIZE   - SIZE OF SET NAME (IN CHARACTERS)                      *
*     $NAME    - SET NAME IN UNPACKED TEXT FORMAT (A1)                 *
*     $INDEX   - CURENT POINTER INTO OUTPUT BUFFER                    *
*     $LINKN - SCRATCH LINK                                            *
*     $LINKH - SCRATCH LINK                                            *
*     $SETIN - INDEX INTO THE INPUT BUFFER BUFFER AND I/O UNITS
*     $POINT - POINTER AT NAME OF OWNER.                               *
*     $OTYPE - TYPE OF OWNER (0 - GRP, 1-AREA)                         *
*     $ORDER - ORDER OF SET (SORTED,FIRST,LAST...)                     *
*     $STATS - FLAG TO INDICATE IF STATISTICS ARE TO BE COLLECTED ON   *
*              THIS SET.                                               *
*     $SET   - TEMP VARIABLE..COUNTER FOR NUMBER OF MEMBERS IN THIS SET*
*                                                                      *
************************************************************************
     .,        $AREA , $CODE , $NSTRT ,  $STATS , $INDEX , $NSZ
     .,        $SBCOD , $ORDER , $OTYPE , $LNGTH
      EQUIVALENCE
     .( $AREA  , BUFFER( 1) ) ,
     .( $CODE  , BUFFER( 2) ) ,
     .( $SBCOD , BUFFER( 3) ) ,
     .( $SETN  , BUFFER( 4) ) ,
     .( $OGRP  , BUFFER( 5) ) ,
     .( $ORDER , BUFFER( 6) ) ,
     .( $OTYPE , BUFFER( 7) ) ,
     .( $PNEXT , BUFFER( 8) ) ,
     .( $PRIOR , BUFFER( 9)  ) ,
     .( $STATS , BUFFER(10) ) ,
     .( $NSIZE , BUFFER(11) ) ,
     .( $NAME  , BUFFER(12) )
      $NSTRT = $NSIZE+13
      $LNGTH = $NSIZE+12+BUFFER($NSIZE+12)
      $NSZ   = $LNGTH - $NSTRT + 1
      WRITE(OUNIT,1)$NSZ,(BUFFER($INDEX),$INDEX=$NSTRT,$LNGTH)
      IF($OTYPE.EQ.1)WRITE(OUNIT,2)$NSIZE,($NAME($INDEX),$INDEX=1,$NSIZE
     .);GO TO 10000
      WRITE(OUNIT,3)$NSIZE,($NAME($INDEX),$INDEX=1,$NSIZE)
10000 CONTINUE
      IF($ORDER.EQ.0)WRITE(OUNIT,4);GO TO 100
      IF($ORDER.EQ.1)WRITE(OUNIT,5);GO TO 100
      IF($ORDER.EQ.4)WRITE(OUNIT,6);GO TO 100
      IF($ORDER.EQ.6)WRITE(OUNIT,9);GOTO 100
      IF($ORDER.EQ.7)WRITE(OUNIT,10);GOTO 100
      IF($ORDER.EQ.8)WRITE(OUNIT,7);GO TO 100
      IF($ORDER.EQ.9)WRITE(OUNIT,8);GO TO 100
100    IF($PRIOR.NE.0)WRITE(OUNIT,11)
      IF($STATS.EQ.1)WRITE(OUNIT,12)
      WRITE(OUNIT,13)
      CALL NEXREC(BUFFER)
      RETURN
1     FORMAT(' SET NAME IS ',NA1)
2     FORMAT(T6,' ; OWNER IS AREA',NA1)
3     FORMAT(T6,' ; OWNER IS ',NA1)
4     FORMAT(T6,' ; ORDER IS LAST')
5     FORMAT(T6,' ; ORDER IS PRIOR')
6     FORMAT(T6,' ; ORDER IS SORTED')
7     FORMAT(T6,' ; ORDER IS FIRST')
8     FORMAT(T6,' ; ORDER IS NEXT')
10    FORMAT(T6,' ; ORDER IS SORTED WITH GROUP-NO AS MINOR')
11    FORMAT(T6,' ; LINKED TO PRIOR')
12    FORMAT(T6,' ; STATISTICS ARE REQUIRED')
13    FORMAT(T6,' .')
      END
      SUBROUTINE SCHDEF
************************************************************************
************************************************************************
****   SCHDEF                                                       ****
************************************************************************
************************************************************************
      IMPLICIT LOGICAL (A-Z,$)
************************************************************************
*                                                                      *
*                                                                      *
*        CODES FOR THE OUTPUT RECORD  TYPES                            *
*                                                                      *
************************************************************************
      INTEGER
     . ARCODE , GRCODE , VSCODE , CICODE , ITCODE , IVCODE ,
     . STCODE , MMCODE , PSCODE , SBCODE , ISCODE , ALCODE
*                                                                      *
      COMMON / CODES /
     . ARCODE , GRCODE , VSCODE , CICODE , ITCODE , IVCODE ,
     . STCODE , MMCODE , PSCODE , SBCODE , ISCODE , ALCODE
************************************************************************
*                                                                      *
*                                                                      *
*        INPUT BUFFER AND I/O UNITS
*                                                                      *
      INTEGER BUFFER , BUFFR2 ,INUNIT,OUNIT,TRMNAL
      COMMON / OUTPUT / BUFFER(300) , BUFFR2(300),INUNIT,OUNIT,TRMNAL
************************************************************************
*        BLOCK CONTAINING CURENT PARAMETERS ABOUT THE
*        SCHEMA BEING CREATED
*
************************************************************************
      INTEGER CASIZE,CURARA(32),ERROR,CALIAS,CURREC
      COMMON / CURENT / CASIZE,CURARA,ERROR,CALIAS,CURREC
      INTEGER
     . $AREA , $CODE , $SBCOD,
     . $PASS(2) , $RETIN(8) , $UPDIN(8)
      EQUIVALENCE
     .( $AREA     , BUFFER(1 ) ) ,
     .( $CODE     , BUFFER(2 ) ) ,
     .( $SBCOD   , BUFFER(3) ) ,
     .( $PASS(1)  , BUFFER(4)  ) ,
     .( $RETIN(1) , BUFFER(6)  ) ,
     .( $UPDIN(1) , BUFFER(14) )
      INTEGER I,J,K,BITS
      WRITE(OUNIT,1),BUFFER(1),(BUFFER(I),I=2,BUFFER(1)+1)
      CALL NEXREC(BUFFER)
*     SKIP SCHEMA(SUBSCHEMA) RECORD
10    CALL NEXREC(BUFFER)
      IF($CODE.NE.8)WRITE(OUNIT,3);RETURN
      WRITE(OUNIT,2)$PASS(1),$PASS(2)
      K=0
      DO 100 J=1,8
      IF ($RETIN(J).EQ.0) GO TO 100
      DO 50 I=1,32
      IF (BITS($RETIN(J),I,I).EQ.0) GO TO 50
      IF (K.EQ.0) WRITE (OUNIT,4) (((J-1)*32)+I)
      IF (K.EQ.1) WRITE (OUNIT,6) (((J-1)*32)+I)
      K=1
50    CONTINUE
100   CONTINUE
      K=0
      DO 200 J=1,8
      IF ($UPDIN(J).EQ.0) GO TO 200
      DO 150 I=1,32
      IF (BITS($UPDIN(J),I,I).EQ.0) GO TO 150
      IF (K.EQ.0) WRITE (OUNIT,5) (((J-1)*32)+I)
      IF (K.EQ.1) WRITE (OUNIT,6) (((J-1)*32)+I)
      K=1
150   CONTINUE
200   CONTINUE
      GO TO 10
2     FORMAT(T6,' ; PASSWORD IS ''',2A4,'''')
3     FORMAT(T6,' .')
4     FORMAT(T12, ' , RETRIEVE KEY IS ',I3)
5     FORMAT(T12,' , UPDATE KEY IS ',I3)
6     FORMAT(T20,' , ',I3)
      END
      SUBROUTINE NEXREC($BUFFR)
      IMPLICIT LOGICAL(A-Z,$)
************************************************************************
*                                                                      *
*                                                                      *
*        CODES FOR THE OUTPUT RECORD  TYPES                            *
*                                                                      *
************************************************************************
      INTEGER
     . ARCODE , GRCODE , VSCODE , CICODE , ITCODE , IVCODE ,
     . STCODE , MMCODE , PSCODE , SBCODE , ISCODE , ALCODE
*                                                                      *
      COMMON / CODES /
     . ARCODE , GRCODE , VSCODE , CICODE , ITCODE , IVCODE ,
     . STCODE , MMCODE , PSCODE , SBCODE , ISCODE , ALCODE
************************************************************************
*                                                                      *
*                                                                      *
*        INPUT BUFFER AND I/O UNITS
*                                                                      *
************************************************************************
      INTEGER BUFFER , BUFFR2 ,INUNIT,OUNIT,TRMNAL
      COMMON / OUTPUT / BUFFER(300) , BUFFR2(300),INUNIT,OUNIT,TRMNAL
************************************************************************
*        BLOCK CONTAINING CURENT PARAMETERS ABOUT THE
*        SCHEMA BEING CREATED
*
      INTEGER CASIZE,CURARA(32),ERROR,CALIAS,CURREC
      COMMON / CURENT / CASIZE,CURARA,ERROR,CALIAS,CURREC
*
*
      INTEGER $BUFFR(300)
      INTEGER INIT/0/
      CHARACTER*1  NEXTKEY
      IF(INIT.NE.0)GO TO 10
      WRITE (NEXTKEY,100) INIT
100   FORMAT(A1)
      INIT=1
      OPEN (7,STATUS='OLD',FORM='FORMATTED',RECL=320,
     1ACCESS='KEYED',KEYM=16,USAGE='UPDATE')
      OPEN(INUNIT,STATUS='OLD',FORM='FORMATTED',RECL=1200,
     1ACCESS='KEYED',KEYM=16,USAGE='INPUT')
10    READ (INUNIT,'(300A4)',KEY=NEXTKEY,ERR=20) $BUFFR
      GO TO 30
20    CONTINUE
*     GET SCHEMA RECORD
      INTEGER I
      CHARACTER*16 CSGPKEY
      CALL MAKEKEY(1,0,0,0,CSGPKEY)
      READ (INUNIT,'(300A4)',KEY=CSGPKEY) $BUFFR
      WRITE (OUNIT,1),$BUFFR(1),($BUFFR(I),I=2,$BUFFR(1)+1)
     .,$BUFFR(1),($BUFFR(I),I=2,$BUFFR(1)+1)
      WRITE (OUNIT,2),$BUFFR(1),($BUFFR(I),I=2,$BUFFR(1)+1)
     .,$BUFFR(1),($BUFFR(I),I=2,$BUFFR(1)+1)
      STOP  '    DDL REGENERATION COMPLETE '
30    CURREC = CURREC + 1
      RETURN
1     FORMAT(
     .' END.'/
     .' SUBSCHEMA NAME IS ',NA1,'SUB OF SCHEMA  ',NA1)
2     FORMAT(
     .'    ; COBOL COPY IS ',NA1,'COPY'/
     .'    ; META SYSTEM IS ',NA1,'SYSTEM'/
     .'    ; COMPONENTS ARE ALL.'/
     .' END.')
      END
      SUBROUTINE MAKEKEY($TRECTYP,$TGROUP,$TDISPL,
     @                $TIDENT,CSGPKEY)
************************************************************************
*****************************SUBROUTINE MAKEKEY*************************
************************************************************************
*
**  CSGP AND RSP FILES --- IT COMBINES 4 INTEGER VARIABLES
**                           INTO 1 CHARACTER VARIABLE USING THE
**                         ENCODE AND DECODE OPERATORS
*
************************************************************************
      INCLUDE ERSP_IN01
      INTEGER $TRECTYP,$TGROUP,$TDISPL,$TIDENT,TMPKEY(4)
      ENCODE(16,2000,TMPKEY)$TRECTYP,$TGROUP,$TDISPL,$TIDENT
2000  FORMAT(I2,I8,I2,A4)
      DECODE(16,'(A16)',TMPKEY)CSGPKEY
      RETURN
      END
      INTEGER FUNCTION BITS($WORD,$LEFT,$RIGHT)
************************************************************************
************************************************************************
****                                                                ****
*****        INTEGER FUNCTION BITS($WORD,$LEFT,$RIGHT)             *****
****                                                                ****
************************************************************************
************************************************************************
********************************************************************** *
      IMPLICIT LOGICAL(A-Z,$)
      INTEGER $LEFT,$RIGHT,$WORD
************************************************************************
*                                                                      *
*        THIS FUNCTION RETURNS , RIGHT JUSTIFIED                       *
*        BITS BETWEEN $LEFT AND $RIGHT OUT OF $WORD                    *
*                                                                      *
************************************************************************
      BITS = ISL(ISL($WORD,$LEFT),($RIGHT-$LEFT+1)-32)
      RETURN
      END
