*     COPYRIGHT, (C) HONEYWELL INFORMATION SYSTEMS INC., 1979, 1980
*
      BLOCK DATA COPYRIT1
      INTEGER COPYRITE(16)
     1   /'COPYRIGHT, (C) HONEYWELL INFORMATION SYSTEMS INC., 1979,'
     2  , ' 1980.  '/
      GLOBAL COPYRITE
      END
      BLOCK DATA
************************************************************************
*                                                                      *
*        GLOBAL CONSTANTS THROUGHOUT THE PROGRAM ARE                   *
*           1) CODES FOR THE OUTPUT RECORD  TYPES.                     *
*           2) THE CONSTANTS TRUE AND FALSE                            *
*           3) BIT, A 32 WORD BIT MASK ,EACH WORD WITH ITS             *
*              CORRESPONDING BIT SET.                                  *
*                                                                      *
************************************************************************
*                                                                      *
*        CONSTANT COMMON BLOCK                                         *
*                                                                      *
************************************************************************
      LOGICAL TRUE,FALSE
      INTEGER BIT
      COMMON / CONSTS / BIT(32),TRUE,FALSE
************************************************************************
*                                                                      *
*                                                                      *
*        CODES FOR THE OUTPUT RECORD  TYPES                            *
*        ARCODE   - CODE FOR AREA DEFINITION
*        GRCODE   - CODE FOR GROUP DEFINITION
*        VSCODE   - CODE FOR VIA SET NAME
*        VSCODE+1 - CODE FOR STORAGE SET DEFINITION
*        CICODE   - CODE FOR CONTROL ITEM
*        ITCODE   - CODE FOR NON-CONTROL ITEM
*        IVCODE   - CODE FOR INVERT ITEM
*        STCODE   - CODE FOR SET DEFINITION
*        MMCODE   - CODE FOR MEMBER DEFINITION
*        PSCODE   - CODE FOR PASSWORD DEFINITION
*        SBCODE   - CODE FOR SUBSCHEMA DEFINITION
*        ISCODE   - CODE FOR INDEXED SEQUENTIAL DEFINITION
*
*                                                                      *
*                                                                      *
************************************************************************
      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 / 20 /
      DATA TRUE,FALSE/.TRUE.,.FALSE./
      DATA BIT/
     .Z80000000,Z40000000,Z20000000,Z10000000,
     .Z08000000,Z04000000,Z02000000,Z01000000,
     .Z00800000,Z00400000,Z00200000,Z00100000,
     .Z00080000,Z00040000,Z00020000,Z00010000,
     .Z00008000,Z00004000,Z00002000,Z00001000,
     .Z00000800,Z00000400,Z00000200,Z00000100,
     .Z00000080,Z00000040,Z00000020,Z00000010,
     .Z00000008,Z00000004,Z00000002,Z00000001
     ./
      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
************************************************************************
*                                                                      *
*                                                                      *
*        OUTPUT BUFFER FOR REFORMATTED RECORD                          *
*                                                                      *
************************************************************************
      INTEGER BUFFER
      COMMON / OUTPUT / BUFFER(300)
************************************************************************
*                                                                      *
*        SUBSCHEMA BUFFER .                                            *
*                                                                      *
*                                                                      *
************************************************************************
      INTEGER SUBSCH,CURARA
      COMMON / SSCH   / SUBSCH(15360),CURARA
************************************************************************
*                                                                      *
*        BITS TAKES THREE ARGUMENTS, AN INTEGER VALUE, THE             *
*        LEFTMOST AND RIGHTMOSET BITS TO BE EXTRACTED, AND             *
*        RETURNS THEM RIGHT JUSTIFIED.                                 *
*        BITSET RETURNS TRUE OR FALSE, DEPENDING ON WHETHER THE BIT    *
*        REPRESENTED BY THE SECOND PARAMETER IS SET IN THE FIRST       *
*                                                                      *
************************************************************************
      INTEGER BITS
      LOGICAL BITSET
************************************************************************
*                                                                      *
*        NOW A COMMON BLOCK TO SAVE THE CURRENT AREA,GROUP AND SET     *
*        POINTERS ACROSS SUBROUTINE CALLS                              *
*                                                                      *
************************************************************************
      INTEGER GRPPTR,ARAPTR,SETPTR,ISQPTR,ITMPTR,MEMPTR
      COMMON / SAVGBL /ARAPTR,GRPPTR,SETPTR,ISQPTR,ITMPTR,MEMPTR
*                                                                      *
*                                                                      *
*                                                                      *
*                                                                      *
*                                                                      *
*        LOCAL VARIABLES.                                              *
*        ================                                              *
*                                                                      *
*           $AREA  - CURRENT 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            *
*           $FLPCT - FILL PERCENTAGE OF THE AREA                       *
*           $IKSIZ - NUMBER OF BYTES IN INDEX KEYS                     *
*           $PASIZ - PAGE SIZE IN WORDS                                *
*           $OVMIN - FIRST OVERFLOW PAGE FOR THE INDEXED GROUP DEFINED *
*                    IN THIS AREA.                                     *
*                    FOR THIS AREA.                                    *
*           $NMCNT - NUMBER OF CHARACTERS IN AREA NAME                 *
*           $ARNAM - NAME IN "A1" FORMAT                               *
*           $LINKN - LOCAL TEMP VARIABLE USED TO TRAVERSE LINKS TO     *
*                    FIND THE OVERFLOW MINIMUMS AND MAXIMUMS           *
*                                                                      *
************************************************************************
      INTEGER
     . $AREA  , $CODE  , $SBCOD , $WKINC , $NPAGE , $AREAN , $INVPC ,
     . $CHKSM , $DPLNN , $CIPHR , $JRNAL , $FLPCT , $IKSIZ , $PASIZ ,
     . $OVMIN , $OVMAX , $NMCNT , $ARNAM , $LINKN
      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) )
************************************************************************
*                                                                      *
*                                                                      *
*        EXTRACT THE VARIOUS PARAMETERS OF AN AREA FROM THE AREA       *
*        DEFINITION RECORD, AS DEFINED IN THE EDMS MANUAL              *
*                                                                      *
************************************************************************
10    CONTINUE
      CURARA = BITS(SUBSCH(ARAPTR+2),00,07)
      $AREA  = CURARA
      $CODE  = ARCODE
      $SBCOD = 0
      $WKINC = BITS(SUBSCH(ARAPTR  ),15,31)
      $NPAGE = BITS(SUBSCH(ARAPTR+1),12,31)
      $AREAN = BITS(SUBSCH(ARAPTR+2),00,07)
      $INVPC = BITS(SUBSCH(ARAPTR+3),00,07)
      $CHKSM = BITS(SUBSCH(ARAPTR+3),08,08)
      $DPLNN = BITS(SUBSCH(ARAPTR+3),09,12)
      $CIPHR = BITS(SUBSCH(ARAPTR+3),13,13)
      $JRNAL = BITS(SUBSCH(ARAPTR+3),14,14)
      $FLPCT = BITS(SUBSCH(ARAPTR+4),00,07)
      $IKSIZ = BITS(SUBSCH(ARAPTR+5),00,15)
      $PASIZ = BITS(SUBSCH(ARAPTR+5),16,31)
************************************************************************
*                                                                      *
*        NOW FIND THE OVERFLOW MINIMUM AND MAXIMUM..THEY WILL          *
*        BE MARKED BY THE VALUE -1 IF NOT SPECIFIED FOR THIS AREA.     *
*                                                                      *
************************************************************************
      $OVMIN = -1
      $OVMAX = -1
      $LINKN = ARAPTR
************************************************************************
*                                                                      *
*                                                                      *
*        FOLLOW THE ISEQ LINKS UNTIL WE ARE POINTING BACK AT THE       *
*        AREA DEFINITON, IN WHICH CASE THERE IS NO OVERFLOW DEFINED,   *
*        OR UNTIL WE FIND AN OVERFLOW DEFINITION (BIT 27 RESET)        *
************************************************************************
20    CONTINUE
      $LINKN = BITS(SUBSCH($LINKN+3),15,31)+1
      IF($LINKN.EQ.ARAPTR)GO TO 30
      IF(BITSET(SUBSCH($LINKN),27)) GO TO 20
      $OVMIN = BITS(SUBSCH($LINKN+1),12,31)
      $OVMAX = BITS(SUBSCH($LINKN+2),12,31)
30    CONTINUE
************************************************************************
*                                                                      *
*                                                                      *
*        EXPAND THE TEXTC BYTE STRING THAT IS THE AREA NAME INTO       *
*        "UNPACKED TEXTC" FORMAT.                                      *
*                                                                      *
*                                                                      *
************************************************************************
      CALL EXPAND(SUBSCH(ARAPTR+6),$ARNAM,$NMCNT)
************************************************************************
*                                                                      *
*                                                                      *
*        WRITE OUT THE RECORD WE HAVE JUST FORMATTED UP,               *
*        AND DUMP OUT ALL THE INDEX-SEQUENTIAL DEFINITIONS FOR  THIS   *
*        AREA.                                                         *
*                                                                      *
*                                                                      *
************************************************************************
      CALL DMPREC(.FALSE.)
      CALL ISQDEF
************************************************************************
*                                                                      *
*                                                                      *
*        FIND THE POINTER TO THE GROUP DEFINITIONS FOR THIS AREA AND   *
*        THEN DEFINE THE GROUPS .                                      *
*                                                                      *
*                                                                      *
************************************************************************
      GRPPTR = BITS(SUBSCH(ARAPTR+4),15,31)+1
      CALL GRPDEF
************************************************************************
*                                                                      *
*                                                                      *
*                                                                      *
*        NOW FIND THE POINTER TO THE NEXT AREA. IF IT IS NON-TRIVIAL   *
*        THEN FOLLOW IT , ELSE RETURN                                  *
*                                                                      *
*                                                                      *
************************************************************************
      ARAPTR = BITS(SUBSCH(ARAPTR+2),15,31)+1
      IF(ARAPTR.NE.1)GO TO 10
      RETURN
      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
************************************************************************
*                                                                      *
*                                                                      *
*        SAVE POINTERS TO CURRENT AREA,GROUP AND SET DEFINITINS        *
*                                                                      *
************************************************************************
      INTEGER ARAPTR,GRPPTR,SETPTR,ISQPTR,ITMPTR,MEMPTR
      COMMON / SAVGBL /ARAPTR,GRPPTR,SETPTR,ISQPTR,ITMPTR,MEMPTR
************************************************************************
*                                                                      *
*                                                                      *
*        OUTPUT BUFFER FOR REFORMATTED RECORD                          *
*                                                                      *
*                                                                      *
      INTEGER BUFFER
      COMMON / OUTPUT / BUFFER(300)
************************************************************************
*                                                                      *
*        SUBSCHEMA BUFFER .                                            *
*                                                                      *
************************************************************************
      INTEGER SUBSCH,CURARA
      COMMON / SSCH   / SUBSCH(15360),CURARA
************************************************************************
*                                                                      *
*        CONSTANTS                                                     *
*                                                                      *
************************************************************************
      INTEGER BIT
      LOGICAL TRUE,FALSE
      COMMON / CONSTS / BIT(32),TRUE,FALSE
************************************************************************
*                                                                      *
*        BITS TAKES THREE ARGUMENTS, AN INTEGER VALUE, THE             *
*        LEFTMOST AND RIGHTMOSET BITS TO BE EXTRACTED, AND             *
*        RETURNS THEM RIGHT JUSTIFIED.                                 *
*        BITSET RETURNS TRUE OR FALSE DEPENDING ON WHETHER THE BIT     *
*        REPRESENTED BYE THE SECOND PARAMETER IS SET IN THE            *
*        INTEGER REPRESENTED BY THE FIRST PARAMETER                    *
*                                                                      *
************************************************************************
      INTEGER BITS
      LOGICAL BITSET
*                                                                      *
*                                                                      *
*        LOCAL VARIABLES.                                              *
*        ================                                              *
*                                                                      *
*                                                                      *
*           $AREA  - CURRENT 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                                  *
*           $DBGSZ - DATA BASE GROUP SIZE IN WORDS                     *
*           $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)        **
*           $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       *
*           $LINKN - TEMP VARIABLE FOR FOLLOWING LINKS                 *
*           $LINKH - TEMP VARIABLE FOR FOLLOWING LINKS                 *
*           $INDEX - SCRATCH POINTER INTO THE OUTPUT BUFFER            *
*           $SETPT - SCRATCH POINTER INTO THE OUTPUT BUFFER            *
*           $SAVTP - INTEGER VARIABLE USED TO SAVE THE GROUP TYPE      *
*                    PAST WRITING OUT THE RECORD, TO DETERMINE IF      *
*                    THIS WAS A VIA SET OR DIRECT GROUP, AND IF THERE  *
*                    ARE STORAGE SETS ASSOCIATED.                      *
*           $DUPE -  FLAG TO INDICATE IF DUPLICATES ARE ALLOWED, IF THIS
*                    IS A CALC GROUP
*                                                                      *
************************************************************************
      INTEGER
     . $GRPNM , $WKINC , $STREL , $RTLOK , $UPLOK , $STATS , $GRTYP ,
     . $DBGSZ , $WSSIZ , $PGMIN , $PGMAX , $PGPRM , $CNREC , $BYTES ,
     . $NSIZE , $GNAME , $SETCT , $LINKN , $LINKH , $AREA  , $CODE  ,
      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) )
1000  CONTINUE
************************************************************************
*                                                                      *
*        NOW INITIALIZE POINTERS INTO THE BUFFER FOR THE               *
*        VARIABLE PORTION OF THIS RECORD                               *
*                                                                      *
************************************************************************
      $INDEX = 22
      $SETPT = 21
************************************************************************
*                                                                      *
*        NOW EXTRACT INFORMATION ABOUT THE GROUP FROM THE GROUP        *
*        DEFINITION RECORD AS DEFINED IN THE EDMS MANUAL               *
*                                                                      *
*                                                                      *
************************************************************************
      $CODE  = GRCODE
      $SBCOD = 0
      $WKINC = BITS(SUBSCH(GRPPTR  ),15,31)
      $STREL = BITS(SUBSCH(GRPPTR  ),08,08)
      $GRPNM = BITS(SUBSCH(GRPPTR+1),00,09)
      INTEGER GRNTM
      IF($GRPNM.EQ.1002)$GRPNM=$GRPNM+$AREA
      GRNTM=$GRPNM
      $RTLOK = BITS(SUBSCH(GRPPTR+2),00,07)
      $UPLOK = BITS(SUBSCH(GRPPTR+3),00,07)
************************************************************************
*                                                                      *
*        GET THE GROUP TYPE                                            *
*           0 - VIA SET                                                *
*           1 - DIRECT GROUP                                           *
*           2 - CALC GROUP                                             *
*           3 - INDEXED GROUP                                          *
*                                                                      *
************************************************************************
      $GRTYP = 0
      IF(BITSET(SUBSCH(GRPPTR),09))$GRTYP = 1
      IF(BITSET(SUBSCH(GRPPTR),10))$GRTYP = 2
      IF(BITSET(SUBSCH(GRPPTR),14))$GRTYP = 3
*
*
*        IF THIS IS A CALC GROUP, DETERMINE IF DUPLICATES ARE ALLOWED
*
*
      IF($GRTYP.EQ.2)$DUPE=BITS(SUBSCH(BITS(SUBSCH(GRPPTR+2),15,31)+1),
     .26,27)
      $SAVTP = $GRTYP
************************************************************************
*                                                                      *
*                                                                      *
*        NOW FIND OUT IF THIS GROUP IS A MANUAL MEMBER OF ANY SET      *
*        BY FOLLOWING THE MEMBER LINK                                  *
*                                                                      *
************************************************************************
      $MANUL = 0
      $LINKN = GRPPTR
499   $LINKN = BITS(SUBSCH($LINKN+2),15,31)+1
      IF($LINKN.EQ.GRPPTR)GO TO 500
      $MANUL = IOR(BITS(SUBSCH($LINKN),10,10),$MANUL)
      GO TO 499
500   CONTINUE
************************************************************************
*                                                                      *
*        FIND OUT HOW MUCH STORAGE THE GROUP WILL OCCUPY IN            *
*        THE DATABASE AND IN WORKING STORAGE.                          *
*                                                                      *
*                                                                      *
************************************************************************
      $DBGSZ = BITS(SUBSCH(GRPPTR+4),00,09)
      $WSSIZ = BITS(SUBSCH(GRPPTR+5),00,09)
************************************************************************
*                                                                      *
*                                                                      *
*        IF THE GROUP OCCUPIES NO SPACE, THEN IT IS ONE OF             *
*        THE "INCOMPLETE" GROUPS GENERATED BY EDMS..IGNORE IT.         *
*                                                                      *
*                                                                      *
************************************************************************
      IF($WSSIZ+$DBGSZ.EQ.0)GO  TO 300
************************************************************************
*                                                                      *
*        FIND OUT THE PAGE RANGES FOR THE GROUP, AND THE PAGE          *
*        RANGE PRIME VALUE. THEY DEFAULT TO -1 IF NOT PRESENT          *
*                                                                      *
*                                                                      *
************************************************************************
      $PGMIN = -1
      $PGMAX = -1
      $PGPRM = -1
      IF(.NOT.BITSET(SUBSCH(GRPPTR),12))GO TO 10
      $PGMIN = BITS(SUBSCH(GRPPTR+6),12,31)
      $PGMAX = BITS(SUBSCH(GRPPTR+7),12,31)
      IF(.NOT.BITSET(SUBSCH(GRPPTR),10))GO TO 20
      $PGPRM = BITS(SUBSCH(GRPPTR+8),11,31)
      GO TO 20
10    CONTINUE
      IF(BITSET( SUBSCH(GRPPTR),10))$PGPRM=BITS(SUBSCH(GRPPTR+6),11,31)
20    CONTINUE
************************************************************************
*                                                                      *
*                                                                      *
*           FIND OUT HOW MANY BYTES OF DATA THERE ARE IN THE GROUP     *
*           BY COUNTING THE NUMBER OF BYTES IN EACH ITEM, AND HOW MANY *
*           CONTROL ITEMS THERE ARE.                                   *
*                                                                      *
*                                                                      *
************************************************************************
      $BYTES = 0
      $CNREC = 0
      $LINKN = BITS(SUBSCH( GRPPTR+3),15,31)+1
      IF($LINKN.EQ.GRPPTR) GO TO 15
100   CONTINUE
      $BYTES = $BYTES + BITS(SUBSCH( $LINKN+1),0,10)
      $CNREC = $CNREC + BITS(SUBSCH( $LINKN),8,8)
      $LINKH = BITS(SUBSCH( $LINKN+4),15,31)+1
      IF($LINKN.NE.$LINKH) GO TO 100
15    CONTINUE
************************************************************************
*                                                                      *
*                                                                      *
*        GET THE GROUP NAME IN "UNPACKED TEXTC" FORMAT                 *
*                                                                      *
*                                                                      *
************************************************************************
      CALL NAMTBL(GRPPTR,$NSIZE,$GNAME)
************************************************************************
*                                                                      *
*        STATISTICS FOR THIS GROUP?                                    *
*                                                                      *
************************************************************************
      $STATS = BITS(SUBSCH( GRPPTR+1),14,14)
************************************************************************
*                                                                      *
*        NOW COUNT THE NUMBER OF SETS THIS GROUP IS THE OWNER OF AND   *
*        SAVE THE SET NUMBERS.                                         *
*                                                                      *
************************************************************************
      $SETCT = 0
      $INDEX = $INDEX + $NSIZE
      $SETPT = $SETPT + $NSIZE
      $LINKN = BITS(SUBSCH( GRPPTR+1),15,31)+1
      IF($LINKN .EQ. GRPPTR) GO TO 25
200   CONTINUE
      BUFFER($INDEX) = BITS( SUBSCH($LINKN),15,31)
      $SETCT = $SETCT + 1
      $INDEX = $INDEX + 1
      $LINKN = BITS(SUBSCH( $LINKN+1),15,31)+1
      IF($LINKN.NE.$LINKH) GO TO 200
25    CONTINUE
      BUFFER($SETPT) = $SETCT
************************************************************************
*                                                                      *
*                                                                      *
*        NOW DUMP THE RECORD OUT AND DEFINE ALL THE SETS               *
*        THAT THIS GROUP IS THE OWNER OF.                              *
*                                                                      *
*                                                                      *
************************************************************************
      CALL DMPREC(.FALSE.)
      CALL SETDEF
************************************************************************
*                                                                      *
*        IF THIS IS A DIRECT GROUP OR A VIA SET GROUP, THEN            *
*        GET THE STORAGE SET NAMES AND/OR THE VIA SET NAME             *
*                                                                      *
*                                                                      *
************************************************************************
      IF($SAVTP.LT.2)CALL DSETNM
************************************************************************
*                                                                      *
*        NOW CALL THE  ITEM DUMPING SUBROUTINE                         *
*                                                                      *
************************************************************************
      CALL DMPITM(GRNTM)
************************************************************************
*                                                                      *
*        NOW SEE IF THERE ARE ANY MORE GROUPS, AND IF THERE ARE,       *
*        DEFINE THEM.                                                  *
*                                                                      *
*                                                                      *
************************************************************************
300   $LINKN = BITS(SUBSCH( GRPPTR+4),15,31)+1
      $LINKH = BITS(SUBSCH( GRPPTR+5),15,31)+1
      IF($LINKN.EQ.$LINKH)RETURN
      GRPPTR = $LINKN
      GO TO 1000
      END
      SUBROUTINE DSETNM
************************************************************************
************************************************************************
****                                                                ****
*****        SUBROUTINE DSETNM                                     *****
****                                                                ****
************************************************************************
************************************************************************
      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
************************************************************************
*                                                                      *
*                                                                      *
*        NOW A COMMON BLOCK CONTAINING CURRENT POINTERS TO             *
*        GROUPS, SETS AND AREAS                                        *
*                                                                      *
************************************************************************
      INTEGER ARAPTR,GRPPTR,SETPTR,ISQPTR,ITMPTR,MEMPTR
      COMMON / SAVGBL /ARAPTR,GRPPTR,SETPTR,ISQPTR,ITMPTR,MEMPTR
************************************************************************
*                                                                      *
*                                                                      *
*        OUTPUT BUFFER FOR REFORMATTED RECORD                          *
*                                                                      *
************************************************************************
      INTEGER BUFFER
      COMMON / OUTPUT / BUFFER(300)
************************************************************************
*                                                                      *
*        SUBSCHEMA BUFFER .                                            *
*                                                                      *
************************************************************************
      INTEGER SUBSCH,CURARA
      COMMON / SSCH   / SUBSCH(15360),CURARA
*                                                                      *
*        BITS TAKES THREE INTEGER PARAMETERS, THE SECOND AND THIRD     *
*        THE LEFT AND RIGHT  BIT POSITIONS OF THE FIELD TO EXTRACT     *
*        FROM THE FIRST PARAMETER. THE VALUE IS RETURNED RIGHT         *
*        JUSTIFIED.                                                    *
*        BITSET RETURNS TRUE OR FALSE DEPENDING ON WHETHER THE         *
*        BIT SPECIFIED BY THE SECOND PARAMETER IS SET OR RESET IN THE  *
*        FIRST PARAMETER.                                              *
*                                                                      *
************************************************************************
      INTEGER BITS
      LOGICAL BITSET
************************************************************************
*                                                                      *
*        LOCAL VARIABLES                                               *
*        ===============                                               *
*                                                                      *
*                                                                      *
*           $AREA  - CURRENT AREA                                      *
*           $CODE  - CODE FOR GROUP DEFINITION RECORD (02)             *
*           $SBCOD - CODE FOR VIA SET NAME (10)                        *
*                         FOR STORAGE SET DEF'N RECORD (11)
*           $GRPNM - NUMBER OF GROUP THIS NAME IS ASSOCIATED WITH      *
*           $NSIZE - SIZE OF NAME                                      *
*           $NAME  - "A1" FORMAT NAME                                  *
*           $MEMPT - POINTER AT MEMBER DEFINITION RECORD               *
*                                                                      *
*                                                                      *
************************************************************************
      INTEGER
     . $AREA  , $CODE  , $SBCOD , $GRPNM , $NSIZE , $NAME
      LOGICAL $BOTH
      EQUIVALENCE
     .( $AREA  , BUFFER(1) ) ,
     .( $CODE  , BUFFER(2) ) ,
     .( $SBCOD , BUFFER(3) ) ,
     .( $GRPNM , BUFFER(4) ) ,
     .( $NSIZE , BUFFER(5) ) ,
     .( $NAME  , BUFFER(6) )
************************************************************************
*                                                                      *
*                                                                      *
*        NOW GET THE VIA SET NAME. IF THE VIA SET IS ALSO              *
*        THE STORAGE SET, THEN DUMP THE NAME OUT TWICE.                *
*        FIND THE NAMES BY FOLLOWING THE MEMBER LINK FOR THIS GROUP    *
*        AND THE SET LINK FOR THE MEMBER DEFINITON.                    *
*                                                                      *
*                                                                      *
*                                                                      *
************************************************************************
      MEMPTR = BITS(SUBSCH(GRPPTR+2),15,31)+1
10    CONTINUE
      IF(MEMPTR.EQ.GRPPTR)RETURN
      SETPTR = BITS(SUBSCH(MEMPTR+4),15,31)+1
      $AREA  = CURARA
      $CODE  = GRCODE
      $SBCOD = VSCODE
      $GRPNM = BITS(SUBSCH(GRPPTR+1),00,09)
      CALL NAMTBL(SETPTR,$NSIZE,$NAME)
      $BOTH = .FALSE.
      IF(.NOT.(BITSET(SUBSCH(MEMPTR),30).OR.
      IF(BITSET(SUBSCH(GRPPTR),8).AND.BITSET(SUBSCH(MEMPTR),31))
     .$BOTH = .TRUE.
      IF(BITSET(SUBSCH(MEMPTR),30))$SBCOD=VSCODE+1
      IF(.NOT.$BOTH)CALL DMPREC(.FALSE.);GO TO 20
      CALL DMPREC(.TRUE.)
      $SBCOD = VSCODE
      CALL DMPREC(.FALSE.)
      RETURN
20    CONTINUE
      MEMPTR=BITS(SUBSCH(MEMPTR+2),15,31)+1
      GO TO 10
      END
      SUBROUTINE INVERT($IVPTR)
************************************************************************
************************************************************************
****                                                                ****
*****        SUBROUTINE INVERT($IVPTR)                             *****
****                                                                ****
************************************************************************
************************************************************************
      IMPLICIT LOGICAL(A-Z,$)
      INTEGER GRPPTR,ARAPTR,SETPTR,ISQPTR,ITMPTR,MEMPTR
      COMMON / SAVGBL /ARAPTR,GRPPTR,SETPTR,ISQPTR,ITMPTR,MEMPTR
************************************************************************
*                                                                      *
*                                                                      *
*        CODES FOR THE OUTPUT RECORD  TYPES                            *
*                                                                      *
************************************************************************
      INTEGER
     . ARCODE , GRCODE , VSCODE , CICODE , ITCODE , IVCODE ,
     . STCODE , MMCODE , PSCODE , SBCODE , ISCODE , ALCODE
*                                                                      *
      COMMON / CODES /
     . STCODE , MMCODE , PSCODE , SBCODE , ISCODE , ALCODE
************************************************************************
*                                                                      *
*                                                                      *
*        OUTPUT BUFFER FOR REFORMATTED RECORD                          *
*                                                                      *
************************************************************************
      INTEGER BUFFER
      COMMON / OUTPUT / BUFFER(300)
************************************************************************
*                                                                      *
*        SUBSCHEMA BUFFER .                                            *
*                                                                      *
************************************************************************
      INTEGER SUBSCH,CURARA
      COMMON / SSCH   / SUBSCH(15360),CURARA
************************************************************************
*                                                                      *
*        BITS TAKES THREE ARGUMENTS, AN INTEGER VALUE, THE             *
*        LEFTMOST AND RIGHTMOSET BITS TO BE EXTRACTED, AND             *
*        RETURNS THEM RIGHT JUSTIFIED.                                 *
*                                                                      *
*        BITSET RETURNS TRUE OR FALSE, DEPENDING ON WHETHER THE BIT    *
*        INDICATED BY THE SECOND PARAMETER IS SET OR RESET IN THE      *
*        FIRST                                                         *
*                                                                      *
************************************************************************
      LOGICAL BITSET
************************************************************************
*                                                                      *
*                                                                      *
*                                                                      *
*                                                                      *
*        LOCAL VARIABLES                                               *
*        ===============                                               *
*                                                                      *
*     $AREA  - CURRENT AREA                                            *
*     $CODE  - CODE FOR GROUP DEFINITION (02)                          *
*     $SBCOD - CODE FOR INVERT ITEM DEFINITION (40)                    *
*     $IVGRP      - INVERT GROUP NUMBER                                *
*     $PGMIN      - PAGE RANGE MINIMUM                                 *
*     $PGMAX      - PAGE RANGE MAXIMUM                                 *
*     $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                                  *
*           $SGRP -  THE GROUP NUMBER THE INVERT ITEM BELONGS TO
*                                                                      *
*                                                                      *
************************************************************************
      INTEGER
     . $NAME  , $CODE  , $SBCOD , $IVPTR , $TEMP , $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) )
      $AREA = CURARA
      $CODE = GRCODE
      $SBCOD = IVCODE
************************************************************************
*                                                                      *
*                                                                      *
*           GET THE INVERT GROUP NUMBER.                               *
*           AND THE PAGE RANGES FOR THIS INVERT GROUP                  *
*                                                                      *
************************************************************************
      $SGRP  = BITS(SUBSCH(GRPPTR+1),0,9)
      $IVGRP = BITS(SUBSCH($IVPTR+1),0,9)
      $PGMIN = -1
      $PGMAX = -1
      $PGPRI = -1
      IF(.NOT.BITSET(SUBSCH($IVPTR),12) ) GO TO 10
      $PGMIN = BITS(SUBSCH($IVPTR+6),13,31)
      $PGMAX = BITS(SUBSCH($IVPTR+7),13,31)
      IF(.NOT.BITSET(SUBSCH($IVPTR),10)) GO TO 20
      $PGPRI = BITS(SUBSCH($IVPTR+8),10,31)
      GO TO 20
10    CONTINUE
      IF(.NOT.BITSET(SUBSCH($IVPTR),10)) GO TO 20
      $PGPRI = BITS(SUBSCH($IVPTR+6),10,31)
20    CONTINUE
************************************************************************
*                                                                      *
*                                                                      *
*           FIND OUT IF DUPLICATES ARE ALLOWED FOR THIS GROUP          *
*           BY FOLLOWING THE MEMBER LINK                               *
*                                                                      *
*                                                                      *
************************************************************************
      $TEMP = BITS(SUBSCH($IVPTR+2),15,31)+1
      $DUPE = BITS(SUBSCH($TEMP),26,27)
      IF($DUPE.NE.0)$DUPE=1
      CALL NAMTBL(ITMPTR,$NSIZE,$NAME)
************************************************************************
*                                                                      *
*                                                                      *
*           WRITE OUT THE RECORD AND RETURN                            *
*                                                                      *
*                                                                      *
************************************************************************
      CALL DMPREC(.FALSE.)
      RETURN
      END
      SUBROUTINE ISQDEF
************************************************************************
************************************************************************
****                                                                ****
*****        SUBROUTINE ISQDEF                                    ******
****                                                                ****
************************************************************************
************************************************************************
      IMPLICIT LOGICAL(A-Z,$)
************************************************************************
*                                                                      *
*                                                                      *
*        THESE ARE THE STANDARD COMMON BLOCKS                          *
*        USED BY THE SUBROUTINES IN THIS PROGRAM.                      *
*                                                                      *
*                                                                      *
*                                                                      *
************************************************************************
*                                                                      *
*                                                                      *
*        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
************************************************************************
*                                                                      *
*                                                                      *
*        OUTPUT BUFFER FOR REFORMATTED RECORD                          *
*                                                                      *
************************************************************************
      INTEGER BUFFER
************************************************************************
*                                                                      *
*        SUBSCHEMA BUFFER .                                            *
*                                                                      *
************************************************************************
      INTEGER SUBSCH,CURARA
      COMMON / SSCH   / SUBSCH(15360),CURARA
************************************************************************
*                                                                      *
*                                                                      *
*        NOW A COMMON BLOCK CONTAINING CURRENT POINTERS TO             *
*        GROUPS, SETS AND AREAS                                        *
*                                                                      *
************************************************************************
      INTEGER ARAPTR,GRPPTR,SETPTR,ISQPTR,ITMPTR,MEMPTR
      COMMON / SAVGBL /ARAPTR,GRPPTR,SETPTR,ISQPTR,ITMPTR,MEMPTR
************************************************************************
*                                                                      *
*        CONSTANTS USED THROUGHOUT THE PROGRAM                         *
*                                                                      *
************************************************************************
      INTEGER BIT
      LOGICAL TRUE,FALSE
      COMMON / CONSTS / BIT(32),TRUE,FALSE
************************************************************************
*                                                                      *
*                                                                      *
*                                                                      *
*        BITS TAKES THREE ARGUMENTS, AN INTEGER VALUE, THE             *
*        LEFTMOST AND RIGHTMOSET BITS TO BE EXTRACTED, AND             *
*        RETURNS THEM RIGHT JUSTIFIED.                                 *
*                                                                      *
*                                                                      *
*                                                                      *
************************************************************************
      INTEGER BITS
************************************************************************
*                                                                      *
*                                                                      *
*                                                                      *
*                                                                      *
*        LOCAL VARIABLES                                               *
*        ===============                                               *
*                                                                      *
*     $AREA  - CURRENT AREA                                            *
*     $CODE  - CODE FOR ISEQ RECORD ( 10)                              *
*     $SBCOD - SUBCODE (ALWAYS ZERO)                                   *
*     $TYPE    - 1 IF THIS IS INDEX LEVEL, 0 IF OVERFLOW               *
*     $LEVEL   - INDEX LEVEL NUMBER                                    *
*     $START   - BEGINNING PAGE NUMBER                                 *
*     $END     - ENDING PAGE NUMBER                                    *
*                                                                      *
************************************************************************
      INTEGER
     . $TYPE  , $LEVEL , $START , $END   , $CODE  , $AREA  ,
     . $SBCOD
      EQUIVALENCE
     .( $AREA  , BUFFER(1) ) ,
     .( $CODE  , BUFFER(2) ) ,
     .( $SBCOD , BUFFER(3) ) ,
     .( $TYPE  , BUFFER(4) ) ,
     .( $LEVEL , BUFFER(5) ) ,
     .( $START , BUFFER(6) ) ,
     .( $END   , BUFFER(7) )
      ISQPTR = BITS(SUBSCH(ARAPTR+3),15,31)+1
      IF(ISQPTR.EQ.ARAPTR)RETURN
************************************************************************
*                                                                      *
*                                                                      *
*        EXTRACT THE RELEVENT INFORMATION FROM THE DEFINITION          *
*        AND WRITE IT OUT.                                             *
*                                                                      *
************************************************************************
10    CONTINUE
      $AREA = CURARA
      $CODE = ISCODE ; $SBCOD  = 0
      $TYPE  = BITS(SUBSCH(ISQPTR  ),28,28)
      $LEVEL = BITS(SUBSCH(ISQPTR  ),29,31)
      $START = BITS(SUBSCH(ISQPTR+1),12,31)
      $END   = BITS(SUBSCH(ISQPTR+2),12,31)
      CALL DMPREC(.FALSE.)
************************************************************************
*                                                                      *
*        FIND THE LINK TO THE NEXT DEFINITION..IF IT DOES NOT          *
*        POINT AT AN ISEQ DEFINITION, THEN THERE ARE NO MORE IN THIS   *
*        CHAIN.                                                        *
*                                                                      *
************************************************************************
      ISQPTR = BITS(SUBSCH(ISQPTR+3),15,31)+1
      IF (BITS(SUBSCH(ISQPTR),0,7).EQ.10) GO TO 10
      RETURN
      END
      SUBROUTINE DMPITM(GRNTM)
************************************************************************
************************************************************************
****                                                                ****
*****        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
************************************************************************
*                                                                      *
*                                                                      *
*        OUTPUT BUFFER FOR REFORMATTED RECORD                          *
*                                                                      *
************************************************************************
      INTEGER BUFFER
      COMMON / OUTPUT / BUFFER(300)
************************************************************************
*                                                                      *
*        SUBSCHEMA BUFFER .                                            *
*                                                                      *
************************************************************************
      INTEGER SUBSCH,CURARA
      COMMON / SSCH   / SUBSCH(15360),CURARA
************************************************************************
*                                                                      *
*        CONSTANTS USED THROUGHOUT THE PROGRAM                         *
*                                                                      *
************************************************************************
      INTEGER BIT
      LOGICAL TRUE,FALSE
      COMMON / CONSTS / BIT(32),TRUE,FALSE
************************************************************************
*                                                                      *
*                                                                      *
*        COMMON BLOCK TO SAVE THE POINTERS AT THE CURRENT              *
*        GROUP , AREA , AND SET DEFINITIONS.                           *
*                                                                      *
*                                                                      *
************************************************************************
      INTEGER GRPPTR,ARAPTR,SETPTR,ISQPTR,ITMPTR,MEMPTR
      COMMON / SAVGBL / ARAPTR,GRPPTR,SETPTR,ISQPTR,ITMPTR,MEMPTR
************************************************************************
*                                                                      *
*                                                                      *
*        BITS TAKES THREE ARGUMENTS, AN INTEGER VALUE, THE             *
*        LEFTMOST AND RIGHTMOSET BITS TO BE EXTRACTED, AND             *
*        RETURNS THEM RIGHT JUSTIFIED.                                 *
*                                                                      *
*                                                                      *
*                                                                      *
************************************************************************
      INTEGER BITS
      LOGICAL BITSET
************************************************************************
*                                                                      *
*                                                                      *
*                                                                      *
*                                                                      *
*        LOCAL VARIABLES                                               *
*        ===============                                               *
*                                                                      *
*     $AREA  - CURRENT AREA                                            *
*     $CODE  - CODE FOR GROUP DEFINITION ( 02 )                        *
*     $SBCOD - CODE FOR NON-CONTROL ITEM DEFINITION (30)
*     $GRNUM - GROUP NUMBER ASSOCIATED WITH THIS ITEM                  *
*     $CONT  - 0 IF NON-CONTROL ITEM // NON-ZERO IF CONTROL ITEM  i.e.:
*                                                    2 - CALC
*                                                    4 - ASC SORT KEY
*                                                    6 - DSC SORT KEY
*     $TYPE    - ITEM TYPE :                                           *
*                 0 -> SIGNED NUMBER                                   *
*                 1 -> ALPHANUMERIC                                    *
*                 2 -> NUMERIC                                         *
*                 3 -> ALPHABETIC                                      *
*                 4 -> BINARY                                          *
*                 5 -> FLOATING SHORT
*                 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                                        *
*     $LINKH - SCRATCH VARIABLE                                        *
*     $CIND  - SCRATCH VARIABLE                                        *
*     $INDEX - SCRATCH VARIABLE                                        *
*     $ITEND - SCRATCH VARIABLE                                        *
*     $D,$E,$F,$C - LOGICAL VARIABLES CORRESPONDING TO                 *
*                   FLAGS C,D,E,F IN THE DEFINITION IN THE EDMS        *
*                   MANUAL                                             *
*                                                                      *
************************************************************************
      INTEGER
     . $CONT  , $TYPE  , $INVRT , $WSINC , $FINC  , $AREA  , $CODE  ,
     . $RTLOC , $UPLOC , $NSIZE , $NAME  , $INDEX , $GRNUM , $TIMES ,
     .  $LINKH , $CPTR  , $CIND  , $ISIZE , $ITEND , $SBCOD
      INTEGER
     .           M$LINK , CD$TYP , C$DEF , C$NEXT , R$TYPE , CAL$CT
      LOGICAL
     . $C , $D , $E , $F
      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) )
**************************************
*               DECLARE CONTROL DEF REOCRD DATA
************************************************************************
*     $AREA - CONTREC(1) - CURRENT AREA
*     $CODE -        (2) - CODE FOR GRP DEFINITION (02)
*     $SBCOD-        (3) - CODE FOR CONTROL ITEM DEFINITION  (25)
*     $GRNUM-        (4) - GROUP NUMBER ASSOCIATED WITH THESE ITEMS
*    BUFFER (5)-     (5) - NUMCTI - NUMBER OF CONTROL ITEMS IN GRP
*    BUFFER (6)- CONTREC(6)+N*4) - CD$TYP - TYPE OF CONTROL ITEM:
*                                               2 - CALC
*                                               4 - ASC SORT KEY
*                                               6 - DSC SORT KEY
*    BUFFER (7)-        (7)+N*4) - $FINC - FILE INCREMENT
*    BUFFER (8)-        (8)+N*4) - CAL$CT - POSITION OF ITEM IN CHAIN
*    BUFFER (9)-        (9)+N*4) - SETNO - SET NUMBER
**********  ABOVE 4 FIELDS REPEAT N TIMES i.e. NUMBER OF CNTRL ITEMS IN THIS GRP
*     POSPTR- LOCAL VARIABLE USED TO INDEX CONTREC
*     TNAME - LOCAL VARIABLE TO STORE NAME WHICH IS HASHED TO CREATE SETNO
*
*
*
************************************************************************
      INTEGER CONTREC(300),NUMCTI,POSPTR,SETNO,TNAME(33),HASHED,GRNTM
      EQUIVALENCE (CONTREC(5),NUMCTI)
************************************************************************
*                                                                      *
*        FIND THE POINTER TO THE ITEM DEFINITION                       *
*                                                                      *
************************************************************************
      ITMPTR = BITS(SUBSCH(GRPPTR+3),15,31)+1
C     INIT CONTREC BUFFER
      NUMCTI=0
      CONTREC(1)=CURARA
      CONTREC(2)=GRCODE
      CONTREC(3)=CICODE
      POSPTR=6
      CONTREC(4)=GRNTM
      IF(ITMPTR.EQ.GRPPTR)GOTO 599
10    CONTINUE
************************************************************************
*                                                                      *
*                                                                      *
*        NOW EXTRACT ALL THE INFO POSSIBLE FROM THE ITEM               *
*        DEFINITION RECORD.                                            *
*                                                                      *
*                                                                      *
      $AREA = CURARA
      $SBCOD = ITCODE
      $CODE = GRCODE
      $GRNUM = BITS(SUBSCH(GRPPTR+1),0,9)
      IF($GRNUM.EQ.1002)$GRNUM=$GRNUM+$AREA
      $C = BITSET(SUBSCH(ITMPTR),12)
      $D = BITSET(SUBSCH(ITMPTR+2),13)
      $E = BITSET(SUBSCH(ITMPTR+2),14)
      $F = BITSET(SUBSCH(ITMPTR+2),11)
      $CONT  = BITS(SUBSCH(ITMPTR)       ,08,08)
      $TYPE  = BITS(SUBSCH(ITMPTR)       ,09,11)
      $INVRT = BITS(SUBSCH(ITMPTR)       ,12,12)
      $WSINC = BITS(SUBSCH(ITMPTR)       ,13,31)
      $ISIZE = BITS(SUBSCH(ITMPTR+1),00,10)
      $FINC  = BITS(SUBSCH(ITMPTR+1),20,31)
      $RTLOC = BITS(SUBSCH(ITMPTR+2),00,07)
      $UPLOC = BITS(SUBSCH(ITMPTR+3),00,07)
************************************************************************
*                                                                      *
*                                                                      *
*        GET THE ITEM NAME                                             *
*                                                                      *
************************************************************************
      CALL NAMTBL(ITMPTR,$NSIZE,$NAME)
************************************************************************
*                                                                      *
*                                                                      *
*        IF THERE IS NO CHECK AND NO INVERSION, THEN JUST              *
*        DUMP THE RECORD AS IT IS                                      *
*                                                                      *
*                                                                      *
************************************************************************
************************************************************************
*                                                                      *
*        GET THE POINTER TO THE CHECK DEFINITION                       *
*                                                                      *
*                                                                      *
************************************************************************
      IF($C.AND..NOT.$F)
     .$CPTR = BITS(SUBSCH(ITMPTR+6),15,31)+1;GOTO 20
      $CPTR = BITS(SUBSCH(ITMPTR+5),15,31)+1
20    CONTINUE
************************************************************************
*                                                                      *
*        GET THE ACTUAL CHECK VALUES.                                  *
*                                                                      *
************************************************************************
      $ITEND = $NSIZE + 15 +BUFFER(14+$NSIZE)
30    $TIMES = BITS(SUBSCH($CPTR),8,9)
      IF($TIMES.EQ.0)$TIMES=2;GO TO 31
      IF($TIMES.EQ.1)$TIMES=4;GO TO 31
      $TIMES = 8
31    CONTINUE
      BUFFER($ITEND) = $TIMES
      $ITEND = $ITEND + 1
      BUFFER($ITEND) = BITS(SUBSCH($CPTR),14,14)
      $CIND = $CPTR+1
      $ITEND = $ITEND + 1
      DO 99, $INDEX = 1,$TIMES
         BUFFER($ITEND) = SUBSCH($CIND)
         $ITEND = $ITEND+1
         $CIND = $CIND+1
99    CONTINUE
      $CPTR = BITS(SUBSCH($CPTR),15,31)+1
************************************************************************
*                                                                      *
*                                                                      *
*        ONE.                                                          *
*                                                                      *
*                                                                      *
************************************************************************
      IF($CPTR.NE.ITMPTR) GO TO 30
40    CONTINUE
      IF($CONT.EQ.0)GO       TO 50
C     FIND CONTROL DEF INFO FOR THIS ITEM
      M$LINK=BITS(SUBSCH(ITMPTR+2),15,31)+1
48    C$DEF=M$LINK;CD$TYP=BITS(SUBSCH(C$DEF),9,12)
      C$NEXT=BITS(SUBSCH(C$DEF+1),15,31)+1
41    R$TYPE=BITS(SUBSCH(C$NEXT),0,7)
C     FIND MEMBER DEF ALONG CONTROL LINK
      IF(R$TYPE.EQ.4)GO TO 42
      C$NEXT=BITS(SUBSCH(C$NEXT+1),15,31)+1
      GO TO 41
42    CAL$CT=1
C     GET SET NUMBER
      CALL NAMTBL(BITS(SUBSCH(C$NEXT+4),15,31)+1,TNAME,TNAME(2))
      SETNO=BITS(SUBSCH(C$NEXT+4),15,31)
      IF(CD$TYP.EQ.4.AND.BITSET(SUBSCH(C$NEXT),19))CD$TYP=8
43    C$NEXT=BITS(SUBSCH(C$NEXT+1),15,31)+1
      IF(C$NEXT.EQ.C$DEF)GO TO 44
      CAL$CT=CAL$CT+1
      GO TO 43
44    CONTREC(POSPTR)=CD$TYP
      CONTREC(POSPTR+1)=$FINC
      CONTREC(POSPTR+2)=CAL$CT
      CONTREC(POSPTR+3)=SETNO
      POSPTR=POSPTR+4
      NUMCTI=NUMCTI+1
45    CONTINUE
      M$LINK=BITS(SUBSCH(M$LINK+2),15,31)+1
      IF(M$LINK.EQ.ITMPTR)GO TO 50
      GO TO 48
50    CONTINUE
      CALL DMPREC(.FALSE.)
      IF(BITSET(SUBSCH(ITMPTR),12))CALL INVERT(BITS(SUBSCH(ITMPTR+5),15
     .,31)
     .+1)
************************************************************************
*                                                                      *
*        GET THE NEXT ITEM IN THE CHAIN (FOR THE CURRENT GROUP)        *
*                                                                      *
*                                                                      *
************************************************************************
      $LINKH = BITS(SUBSCH(ITMPTR+4),15,31)+1
      ITMPTR = BITS(SUBSCH(ITMPTR+3),15,31)+1
      IF (ITMPTR.NE.$LINKH) GO TO 10
C     OUTPUT CONTROL ITEM RECORD (CICODE)
599   DO 600 CAL$CT = 1,POSPTR
600   BUFFER(CAL$CT)=CONTREC(CAL$CT)
      CALL DMPREC(.FALSE.)
      RETURN
      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
************************************************************************
*                                                                      *
*                                                                      *
*        COMMON BLOCK TO SAVE GLOBAL POINTERS AT THE NEXT              *
*        AREA,GROUP ,AND SET                                           *
*                                                                      *
*                                                                      *
************************************************************************
      INTEGER ARAPTR,GRPPTR,SETPTR,ISQPTR,ITMPTR,MEMPTR
      COMMON / SAVGBL / ARAPTR,GRPPTR,SETPTR,ISQPTR,ITMPTR,MEMPTR
************************************************************************
*                                                                      *
*                                                                      *
*        OUTPUT BUFFER FOR REFORMATTED RECORD                          *
*                                                                      *
************************************************************************
      INTEGER BUFFER
      COMMON / OUTPUT / BUFFER(300)
************************************************************************
*                                                                      *
*        SUBSCHEMA BUFFER .                                            *
*                                                                      *
************************************************************************
      INTEGER SUBSCH,CURARA
      COMMON / SSCH   / SUBSCH(15360),CURARA
************************************************************************
*                                                                      *
*        CONSTANTS USED THROUGHOUT THE PROGRAM                         *
*                                                                      *
************************************************************************
      INTEGER BIT
      LOGICAL TRUE,FALSE
      COMMON / CONSTS / BIT(32),TRUE,FALSE
************************************************************************
*                                                                      *
*                                                                      *
*                                                                      *
*        BITS TAKES THREE ARGUMENTS, AN INTEGER VALUE, THE             *
*        LEFTMOST AND RIGHTMOSET BITS TO BE EXTRACTED, AND             *
*        RETURNS THEM RIGHT JUSTIFIED.                                 *
*                                                                      *
*                                                                      *
*                                                                      *
************************************************************************
      INTEGER BITS
************************************************************************
*                                                                      *
*                                                                      *
*                                                                      *
*                                                                      *
*        LOCAL VARIABLES                                               *
*        ===============                                               *
*                                                                      *
*     $AREA  - CURRENT AREA                                            *
*     $CODE  - CODE FOR SET DEFINITIONS                                *
*     $SBCOD - CODE FOR MEMBER DEFINITIONS (10)                        *
*                   FOR ALIAS DEF'N RECORD (20)
*     $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                      *
*     $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                 *
*     $ALIAC - COUNT OF NUMBER OF ALIAS DEFINITIONS ASSOCIATED
*              WITH THIS MEMBER DEFINITION
*     $NSIZE - COUNT OF CHARACTERS IN GROUP NAME                       *
*     $NAME  - OWNER  GROUP NAME                                       *
*     $ANSIZ - SIZE OF ITEM NAME IN ALIAS DEFININITION
*     $ANAME - ITEM NAME FOR ALIAS DEF'N
*     $LINKH - SCRATCH VARIABLE FOR FOLLOWING LINKS
*     $INDEX - SCRATCH INDEX
*     $KCNT  - SCRATCH VARIABLE TO KEEP COUNT OF INDEX KEYS
*     $CLNKN - SCRATCH VARIABLE USED AS POINTER TO INDEX KEYS
*     $CLNKH = SCRATCH VARIABLE USED AS POINTER TO INDEX KEYS
*     $ALNKN - POINTER TO NEXT ALIAS DEFINITION RECORD IN SUBSCHEMA
*     $IND2  - SCRATCH INDEX
*     $END   - SCRATCH INDEX
*     $GRPNM - GROUP NUMBER OF MEMBER
*                                                                      *
*                                                                      *
************************************************************************
      INTEGER  $SETN  , $PNEXT , $PRIOR , $PHEAD , $ALIAS , $OPTON
     .,        $MANUL , $PSET  , $CSET  , $SORT  , $ORDER , $ANSIZ
     .,        $DUPE  , $SELEC , $STSET , $STGRP , $PRIME , $CONT
     .,        $AREA  , $CODE ,  $LINKH , $INDEX , $ALIAC , $ANAME
     .,        $SBCOD , $NSIZE , $NAME , $KCNT , $CLNKN , $CLNKH
     .,        $ALNKN , $IND2 , $END , TNAME(33) , HASHED , $GRPNM
      EQUIVALENCE
     .( $AREA  , BUFFER( 1) ) ,
     .( $SBCOD , BUFFER( 3) ) ,
     .( $SETN  , BUFFER( 4) ) ,
     .( $GRPNM , BUFFER( 5) ) ,
     .( $PNEXT , BUFFER( 6) ) , ($ANSIZ , BUFFER( 6) ) ,
     .( $PRIOR , BUFFER( 7) ) , ($ANAME , 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) )
      MEMPTR = BITS(SUBSCH(SETPTR+3),15,31)+1
      $LINKH = BITS(SUBSCH(MEMPTR+5),15,31)+1
      IF ($LINKH.EQ.SETPTR) RETURN
10    CONTINUE
      $INDEX = 25
************************************************************************
*                                                                      *
*        EXTRACT INFORMATION ABOUT THE MEMBER FROM MEMBER DEFINITION   *
*        RECORD.                                                       *
*                                                                      *
*                                                                      *
************************************************************************
      $AREA  = CURARA
      $CODE = STCODE
      $SBCOD = MMCODE
      CALL NAMTBL(BITS(SUBSCH(MEMPTR+4),15,31)+1,TNAME,TNAME(2))
      $SETN =BITS(SUBSCH(MEMPTR+4),15,31)
      $GRPNM = BITS(SUBSCH(MEMPTR+1),00,09)
      $PNEXT = BITS(SUBSCH(MEMPTR+2),00,11)
      $PRIOR = BITS(SUBSCH(MEMPTR+3),00,11)
      $PHEAD = BITS(SUBSCH(MEMPTR+4),00,11)
      $ALIAS = BITS(SUBSCH(MEMPTR),08,08)
      $OPTON = BITS(SUBSCH(MEMPTR),09,09)
      $MANUL = BITS(SUBSCH(MEMPTR),10,10)
      $PSET  = BITS(SUBSCH(MEMPTR),19,19)
      $CSET  = BITS(SUBSCH(MEMPTR),28,28)
      $SORT  = BITS(SUBSCH(MEMPTR),20,21)
      $ORDER = BITS(SUBSCH(MEMPTR),22,25)
      $DUPE  = BITS(SUBSCH(MEMPTR),26,27)
      $SELEC = BITS(SUBSCH(MEMPTR),29,29)
      $STSET = BITS(SUBSCH(MEMPTR),30,30)
      $PRIME = BITS(SUBSCH(MEMPTR),31,31)
      $CONT  = BITS(SUBSCH(MEMPTR),11,11)
      $STGRP = BITS(SUBSCH(BITS(SUBSCH(MEMPTR+4),15,31)+2),0,9)
************************************************************************
*                                                                      *
*                                                                      *
*        GET THE NAME OF THE MEMBER GROUP                              *
*                                                                      *
*                                                                      *
************************************************************************
      CALL NAMTBL(BITS(SUBSCH(MEMPTR+5),15,31)+1,$NSIZE,$NAME)
      $INDEX = $INDEX + $NSIZE
************************************************************************
*                                                                      *
*     NOW GET THE TEXT NAMES AND TYPE (ASCENDING OR DESCENDING) OF     *
*     THE SORT KEYS ASSOCIATED WITH THIS MEMBER                        *
*                                                                      *
*                                                                      *
************************************************************************
      $KCNT = $INDEX - 1
      BUFFER($KCNT) = 0
      $CLNKN = BITS(SUBSCH(MEMPTR+1),15,31)+1
      IF($ORDER.NE.4) GO TO 20000
      $CLNKH = BITS(SUBSCH($CLNKN+3),15,31)+1
30000 CONTINUE
      BUFFER($KCNT) = BUFFER($KCNT) + 1
      BUFFER($INDEX) = BITS(SUBSCH($CLNKN),9,12)
      $INDEX = $INDEX + 1
      CALL NAMTBL(BITS(SUBSCH($CLNKN+4),15,31)+1,BUFFER($INDEX),
     .BUFFER($INDEX+1))
      $INDEX = $INDEX + BUFFER($INDEX) + 1
      IF(BUFFER($INDEX).EQ.0)GO TO 3600
      $END = $INDEX + BUFFER($INDEX) + 1
      DO 3500, $IND2 = $INDEX,$END
3500  BUFFER($IND2) = 0
3600  CONTINUE
      $CLNKN = BITS(SUBSCH($CLNKN+1),15,31)+1
      IF($CLNKN.NE.$CLNKH) GO TO 30000
************************************************************************
*                                                                      *
*     NOW DUMP THE RECORD
*     AFTER THE MEMBER DEFN RECORD, DUMP ALL THE ITEM NAMES THAT
*     THERE ARE ALIASES DEFINED FOR, BY FOLLOWING ALIAS LINKS
*                                                                      *
*                                                                      *
************************************************************************
20000 CONTINUE
      IF($ALIAS.EQ.0)CALL DMPREC(.FALSE.);GO TO 9898
      CALL DMPREC(.TRUE.)
      $ALNKN = BITS(SUBSCH(MEMPTR+6),15,31)+1
      $ALIAC = 0
      $SBCOD = ALCODE
1010  CONTINUE
      $ALIAC = 1 + $ALIAC
      CALL NAMTBL(BITS(SUBSCH($ALNKN+2),15,31)+1,$ANSIZ,$ANAME)
      $ALNKN = BITS(SUBSCH($ALNKN),15,31)+1
      IF($ALNKN.EQ.MEMPTR)CALL DMPREC(.FALSE.);GO TO 9898
      CALL DMPREC(.TRUE.)
      GO TO 1010
9898  CONTINUE
40000 CONTINUE
      $LINKH = BITS(SUBSCH(MEMPTR+4),15,31)+1
      MEMPTR = BITS(SUBSCH(MEMPTR+3),15,31)+1
      IF(MEMPTR.NE.$LINKH) GO TO 10
      RETURN
      END
      SUBROUTINE SETDEF
************************************************************************
************************************************************************
****                                                                ****
*****        SUBROUTINE SETDEF                                     *****
****                                                                ****
************************************************************************
************************************************************************
      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
************************************************************************
*                                                                      *
*        COMMON BLOCK TO SAVE GLOBAL POINTERS AT THE NEXT              *
*                                                                      *
************************************************************************
      INTEGER ARAPTR,GRPPTR,SETPTR,ISQPTR,ITMPTR,MEMPTR
      COMMON / SAVGBL / ARAPTR,GRPPTR,SETPTR,ISQPTR,ITMPTR,MEMPTR
************************************************************************
*                                                                      *
*                                                                      *
*        OUTPUT BUFFER FOR REFORMATTED RECORD                          *
*                                                                      *
************************************************************************
      INTEGER BUFFER
      COMMON / OUTPUT / BUFFER(300)
************************************************************************
*                                                                      *
*        SUBSCHEMA BUFFER .                                            *
*                                                                      *
************************************************************************
      INTEGER SUBSCH,CURARA
      COMMON / SSCH   / SUBSCH(15360),CURARA
************************************************************************
*                                                                      *
*        CONSTANTS USED THROUGHOUT THE PROGRAM                         *
*                                                                      *
************************************************************************
      INTEGER BIT
      LOGICAL TRUE,FALSE
      COMMON / CONSTS / BIT(32),TRUE,FALSE
************************************************************************
*        BITS TAKES THREE ARGUMENTS, AN INTEGER VALUE, THE             *
*        LEFTMOST AND RIGHTMOSET BITS TO BE EXTRACTED, AND             *
*        RETURNS THEM RIGHT JUSTIFIED.                                 *
*                                                                      *
*                                                                      *
*                                                                      *
************************************************************************
      INTEGER BITS
************************************************************************
*                                                                      *
*                                                                      *
*        LOCAL VARIABLES                                               *
*                                                                      *
*                                                                      *
*     $AREA  - CURRENT 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   - CURRENT POINTER INTO OUTPUT BUFFER                    *
*     $LINKN - SCRATCH LINK                                            *
*     $SETIN - INDEX INTO THE OUTPUT BUFFER FOR MEMBER GRP #'S         *
*     $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*
*     $INCMD - SCRATCH MEMBER INCLUSION MODE INDICATOR                 *
*                                                                      *
************************************************************************
      INTEGER  $SETN , $OGRP , $PNEXT , $PRIOR , $NSIZE , $NAME
     .,        $AREA , $CODE , $LINKN , $LINKH , $STATS , $INDEX
     .,         $SET , $SETIN , $SBCOD , $ORDER , $OTYPE , $POINT
     .,         $SORT , $INCMD , HASHED
      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) )
************************************************************************
*                                                                      *
*        GET POINTER TO SET DEF'N. IF IT POINTS TO GROUP               *
*        DEF'N , THEN RETURN AS THERE ARE NO SETS ASSOCIATED WITH      *
*        THIS GROUP                                                    *
************************************************************************
      SETPTR = BITS(SUBSCH(GRPPTR+1),15,31)+1
      IF(SETPTR.EQ.GRPPTR)RETURN
10000 CONTINUE
      $SETIN = 12
      $AREA  = CURARA
      $CODE = STCODE
      $SBCOD = 0
      $OGRP  = BITS(SUBSCH(SETPTR+1),0,9)
      IF($OGRP.EQ.1002)$OGRP=$OGRP+$AREA
      $ORDER = BITS(SUBSCH(BITS(SUBSCH(SETPTR+3),15,31)+1),22,25)
      $SORT  = BITS(SUBSCH(BITS(SUBSCH(SETPTR+3),15,31)+1),20,21)
*
*  PLAY WITH THE ORDER CODE TO HANDLE "SORTED WITH GROUP-NO..."
*  AS MAJOR OR MINOR KEY. IF GROUP-NO IS A KEY, THEN $ORDER
*  IS 6; THIS WILL IMPLY THE MAJOR CASE. IF $SORT IS 2, THEN
*  THE KEY IS MINOR, SO $ORDER IS SET TO 7.
*
      IF($ORDER.EQ.6.AND.$SORT.EQ.2)$ORDER=7
      $OTYPE = 1
      IF($OGRP.LE.999)$OTYPE = 0 ; GO TO 20
************************************************************************
*                                                                      *
*                                                                      *
*        THE OWNER IS AN AREA..GET THE POINTER TO THE                  *
*        AREA DEFINITON AND THE NAME OF THE AREA                       *
*                                                                      *
************************************************************************
      CALL EXPAND(SUBSCH(ARAPTR+6),$NAME,$NSIZE)
      GO TO 40
************************************************************************
*                                                                      *
*        OWNER GROUP ISN'T AREA..GET TEXT OF THE GROUP                 *
*        NAME.                                                         *
20    CONTINUE
      $POINT = BITS(SUBSCH(SETPTR+2),15,31)+1
      CALL NAMTBL($POINT,$NSIZE,$NAME)
40    CONTINUE
************************************************************************
*
*     GET NAME OF SET
*
*
************************************************************************
      $POINT = $NSIZE + 12
      CALL NAMTBL(SETPTR,BUFFER($POINT),BUFFER($POINT+1))
      $SETN =SETPTR - 1
************************************************************************
*                                                                      *
*        GET POSITION NEXT,PRIOR AND WHETHERE THERE SHOULD BE          *
*        STATS COLLECTED FOR THIS SET                                  *
*                                                                      *
*                                                                      *
************************************************************************
      $PNEXT = BITS(SUBSCH(SETPTR+2),0,11)
      $PRIOR = BITS(SUBSCH(SETPTR+3),0,11)
      $STATS = BITS(SUBSCH(SETPTR),9,9)
************************************************************************
*                                                                      *
*                                                                      *
*        NOW TRAVERSE GROUP LINKS TO FIND THE NUMBERS OF THE           *
*        GROUPS THAT ARE MEMBERS OF THIS SET.                          *
*                                                                      *
*                                                                      *
************************************************************************
      $SETIN = $POINT + BUFFER($POINT) + 1
      $SET = 0
      $LINKN = BITS(SUBSCH(SETPTR+3),15,31)+1
      $INDEX = $SETIN + 1
10    CONTINUE
      BUFFER($INDEX) = BITS(SUBSCH($LINKN+1),0,9)
      $INDEX = $INDEX + 1
      $INCMD = BITS(SUBSCH($LINKN),9,10)
      IF($INCMD.NE.0)$INCMD=1
      BUFFER($INDEX) = $INCMD
      $INDEX = $INDEX + 1
      BUFFER($INDEX) = BITS(SUBSCH($LINKN+2),0,11)
      $INDEX = $INDEX + 1
      BUFFER($INDEX) = BITS(SUBSCH($LINKN+3),0,11)
      $INDEX = $INDEX + 1
      BUFFER($INDEX) = BITS(SUBSCH($LINKN+4),0,11)
      $INDEX = $INDEX + 1
      $LINKH = BITS(SUBSCH($LINKN+4),15,31)+1
      $LINKN = BITS(SUBSCH($LINKN+3),15,31)+1
      $SET = $SET + 1
      IF($LINKN.NE.$LINKH) GO TO 10
30    BUFFER($SETIN) = $SET
************************************************************************
*                                                                      *
*                                                                      *
*        NOW DUMP THE RECORD OUT                                       *
*                                                                      *
*                                                                      *
************************************************************************
      CALL DMPREC(.FALSE.)
************************************************************************
*                                                                      *
*        DEFINE MEMBERS OF THIS SET                                    *
*                                                                      *
************************************************************************
      CALL MEMDEF
************************************************************************
*                                                                      *
*        GET NEXT SET DEFINITION FOR WHICH THE CURRENT                 *
*        GROUP IS THE OWNER                                            *
*                                                                      *
*                                                                      *
************************************************************************
      $LINKN = BITS(SUBSCH(SETPTR+1),15,31)+1
      $LINKH = BITS(SUBSCH(SETPTR+2),15,31)+1
      IF($LINKN.NE.$LINKH)SETPTR=$LINKN;GO TO 10000
      RETURN
      END
      SUBROUTINE PASDEF($START,$COUNT)
************************************************************************
************************************************************************
****                                                                ****
*****        SUBROUTINE PASDEF($START,$COUNT)                      *****
****                                                                ****
************************************************************************
************************************************************************
      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 /
     . STCODE , MMCODE , PSCODE , SBCODE , ISCODE , ALCODE
************************************************************************
*                                                                      *
*                                                                      *
*        OUTPUT BUFFER FOR REFORMATTED RECORD                          *
*                                                                      *
************************************************************************
      INTEGER BUFFER
      COMMON / OUTPUT / BUFFER(300)
************************************************************************
*                                                                      *
*        SUBSCHEMA BUFFER .                                            *
*                                                                      *
************************************************************************
      INTEGER SUBSCH,CURARA
      COMMON / SSCH   / SUBSCH(15360),CURARA
************************************************************************
*                                                                      *
*        CONSTANTS USED THROUGHOUT THE PROGRAM                         *
*                                                                      *
************************************************************************
      INTEGER BIT
      LOGICAL TRUE,FALSE
      COMMON / CONSTS / BIT(32),TRUE,FALSE
************************************************************************
*                                                                      *
*                                                                      *
*        BITS TAKES THREE ARGUMENTS, AN INTEGER VALUE, THE             *
*        RETURNS THEM RIGHT JUSTIFIED.                                 *
*                                                                      *
*                                                                      *
*                                                                      *
************************************************************************
      INTEGER BITS
************************************************************************
*                                                                      *
*                                                                      *
*        INPUT-OUTPUT UNITS.                                           *
*        INPUT ON F:1 , OUTPUT ON F:2                                  *
*                                                                      *
*                                                                      *
************************************************************************
      INTEGER INUNIT,OUNIT,TRMNAL
      COMMON / IOUNIT / INUNIT,OUNIT,TRMNAL
************************************************************************
*                                                                      *
*                                                                      *
*                                                                      *
*                                                                      *
*        LOCAL VARIABLES                                               *
*        ===============                                               *
*                                                                      *
*     $AREA  - CURRENT AREA                                            *
*     $CODE  - CODE FOR PASSWORD DEFINITION RECORD                     *
*     $COUNT - NUMBER OF PASSWORD BLOCKS                               *
*     $START - STARTING PASSWORD BLOCK                                 *
*     $INDEX - TEMP VARIABLE                                           *
*     $LINKN - PASSWORD LINK                                           *
*     $PASS    - PASSWORD IN A4 FORMAT                                 *
*     $RETIN   - RETRIEVE LOCKS                                        *
*     $UPDIN   - UPDATE LOCKS                                          *
************************************************************************
      INTEGER
     . $AREA , $CODE , $INDEX , $LINKN , $COUNT , $SBCOD , $START ,
     . $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) )
      IF ($COUNT.EQ.0)RETURN
      CALL READDI(INUNIT,SUBSCH,$START*512,$COUNT*512)
      CALL MOVEUP(SUBSCH,$COUNT*512)
      $LINKN = 1
10    CONTINUE
      $AREA = CURARA
      $CODE = PSCODE
      $SBCOD = 0
************************************************************************
*                                                                      *
*        GET PASSWORD                                                  *
*                                                                      *
************************************************************************
      $PASS(1) = SUBSCH($LINKN+1)
      $PASS(2) = SUBSCH($LINKN+2)
*                                                                      *
*                                                                      *
*                                                                      *
*                                                                      *
      DO 99, $INDEX = 1,8
         $RETIN($INDEX) = SUBSCH($LINKN+2+$INDEX)
         $UPDIN($INDEX) = SUBSCH($LINKN+10+$INDEX)
99    CONTINUE
*                                                                      *
*                                                                      *
*        DUMP THE RECORDS OUT                                          *
*                                                                      *
*                                                                      *
      CALL DMPREC(.FALSE.)
************************************************************************
*                                                                      *
*                                                                      *
*        IF THE LOW 17 BITS OF THE DEFINITON HEAD ARE ZERO,            *
*        THEN THIS WAS THE LAST DEFINITION.                            *
*                                                                      *
************************************************************************
      IF(BITS(SUBSCH($LINKN),15,31).EQ.0)RETURN
      $LINKN = $LINKN+19
      GO TO 10
      END
      SUBROUTINE SUBDEF($SUBPT)
************************************************************************
************************************************************************
****                                                                ****
*****        SUBROUTINE SUBDEF($SUBPT)                             *****
****                                                                ****
************************************************************************
      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
************************************************************************
*                                                                      *
*                                                                      *
*        COMMON BLOCK TO SAVE GLOBAL POINTERS AT THE NEXT              *
*        AREA,GROUP ,AND SET                                           *
*                                                                      *
************************************************************************
      INTEGER ARAPTR,GRPPTR,SETPTR,ISQPTR,ITMPTR,MEMPTR
      COMMON / SAVGBL / ARAPTR,GRPPTR,SETPTR,ISQPTR,ITMPTR,MEMPTR
************************************************************************
*                                                                      *
*                                                                      *
*                                                                      *
************************************************************************
      INTEGER BUFFER
      COMMON / OUTPUT / BUFFER(300)
************************************************************************
*                                                                      *
*        SUBSCHEMA BUFFER .                                            *
*                                                                      *
************************************************************************
      INTEGER SUBSCH,CURARA
      COMMON / SSCH   / SUBSCH(15360),CURARA
************************************************************************
*                                                                      *
*        CONSTANTS USED THROUGHOUT THE PROGRAM                         *
*                                                                      *
************************************************************************
      INTEGER BIT
      LOGICAL TRUE,FALSE
      COMMON / CONSTS / BIT(32),TRUE,FALSE
************************************************************************
*                                                                      *
*        BITS TAKES THREE ARGUMENTS, AN INTEGER VALUE, THE             *
*        LEFTMOST AND RIGHTMOSET BITS TO BE EXTRACTED, AND             *
*        RETURNS THEM RIGHT JUSTIFIED.                                 *
*                                                                      *
*                                                                      *
*                                                                      *
************************************************************************
      INTEGER BITS
*                                                                      *
*                                                                      *
*                                                                      *
*                                                                      *
*        LOCAL VARIABLES                                               *
*        ================                                              *
*                                                                      *
*     $AREA  - CURRENT AREA                                            *
*     $CODE  - CODE FOR SUBSCHEMA DEFINITION                           *
*     $SBCOD - SUBCODE (ALWAYS ZERO)                                   *
*     $SUBPT - POINTER AT SUBSCHEMA DEFINITION RECORD                  *
*     $YEAR    - YEAR THE SUBSCHEMA WAS CREATED                        *
*     $DAY     - DAY OF THE YEAR                                       *
*     $SPSIZ   - 3 OR 4 BYTE SET POINTERS                              *
*     $ALL     - 1 IF SUBSCHEMA  WAS CREATED USING                     *
*                "COMPONENTS ARE ALL"                                  *
************************************************************************
      INTEGER  $YEAR  , $DAY   , $SPSIZ , $ALL , $AREA , $CODE
      INTEGER  $SUBPT , $SBCOD
      EQUIVALENCE
     .( $AREA  , BUFFER(1) ) ,
     .( $CODE  , BUFFER(2) ) ,
     .( $SBCOD , BUFFER(3) ) ,
     .( $YEAR  , BUFFER(4) ) ,
     .( $DAY   , BUFFER(5) ) ,
     .( $SPSIZ , BUFFER(6) ) ,
     .( $ALL   , BUFFER(7) )
      $AREA = CURARA
      $CODE = SBCODE
      $SBCOD = 0
      $YEAR = BITS(SUBSCH($SUBPT+1),0,15)
      $DAY  = BITS(SUBSCH($SUBPT+1),16,31)
      $ALL   = BITS(SUBSCH($SUBPT),9,9)
      IF($ALL.NE.1)
     @      OUTPUT 'SUBSCHEMA - COMPONENTS ALL - NOT SPECIFIED';
     @      OUTPUT 'CREATE A NEW SUBSCHEMA WITH COMPONENTS ALL';STOP
      CALL DMPREC(.FALSE.)
************************************************************************
*                                                                      *
*     NOW GET AREA DEFINITION                                          *
*                                                                      *
*                                                                      *
************************************************************************
      ARAPTR = BITS(SUBSCH($SUBPT+2),15,31)+1
      CALL DMPARA
      RETURN
      END
      SUBROUTINE BRKTBL(STBLK,BLKCNT)
************************************************************************
************************************************************************
****                                                                ****
*****        SUBROUTINE BRKTBL(STBLK,BLKCNT)                       *****
****                                                                ****
************************************************************************
************************************************************************
*                                                                      *
*        THIS SUBROUTINE READS IN THE NAMETABLE FOR AN                 *
*        EDMS SUBSCHEMA AND WRITES IT INTO A FILE OF
*        NAMES IN "UNPACKED TEXTC" FORMAT.                             *
*                                                                      *
*                                                                      *
*                                                                      *
*     ===============                                                  *
*                                                                      *
*                                                                      *
*        STBLK  - STARTING NAME TABLE BLOCK                            *
*        BLKCNT - NUMBER OF BLOCKS TO READ IN                          *
*        $BYTE  - BYTE INDEX INTO THE NAME TABLE JUST READ IN          *
*        $WORD  - WORD INDEX INTO THE NAME TABLE JUST READ IN          *
*        $INDEX - SCRATCH INDEX                                        *
*        $WDCNT - NUMBER OF WORDS PER NAME TABLE ENTRY                 *
*        $SCALD - FLAG TO INDICATE IF THERE IS PICTURE (0 - NO PICTURE)
*        $OUTPT - POINTER TO POSITION OF CHARACTERS IN ARRAY           *
*        $PCCNT - NUMBER OF CHARACTERS IN PICTURE                      *
*        $NXCHR - THE CURRENT CHARACTER AS EXTRACTED FRUM THE NAME TABLE
*        $TEMP  - SCRATCH VARIABLE                                     *
*                                                                      *
************************************************************************
*                                                                      *
*        GETBYT IS A FUNCTION TO RETURN A SPECIFIED BYTE               *
*        FROM A SPECIFIED ARRAY                                        *
*                                                                      *
*                                                                      *
************************************************************************
       IMPLICIT LOGICAL(A-Z,$)
      INTEGER STBLK,BLKCNT,$BYTE,$WORD,$INDEX,$WDCNT
      INTEGER $SCALD,$OUTPT,GETBYT,$LNAME(65),$ERROR
      INTEGER $PCCNT,$NXCHR,BITS,$TEMP
************************************************************************
*                                                                      *
*     SUBSCHEMA ARRAY                                                  *
*                                                                      *
************************************************************************
      INTEGER SUBSCH(15360),CURARA
      COMMON / SSCH   / SUBSCH,CURARA
************************************************************************
*                                                                      *
*        INPUT OUTPUT UNITS                                            *
*           INPUT ON F:1                                               *
*           OUTPUT ON F:2                                              *
*                                                                      *
************************************************************************
      INTEGER INUNIT,OUNIT,TRMNAL
      COMMON / IOUNIT / INUNIT,OUNIT,TRMNAL
************************************************************************
*                                                                      *
*              START OFF WITH NO NAMES ; RETURN IF THERE AREN'T ANY    *
*                                                                      *
************************************************************************
      IF (BLKCNT.EQ.0)STOP 'RUNNING THIS PROGRAM WITHOUT A NAME TABLE'
************************************************************************
*                                                                      *
*              READ IN THE NAME TABLE AND MOVE IT UP OVER THE          *
*              CHECKSUMS                                               *
*                                                                      *
************************************************************************
      $TEMP = BLKCNT
      CALL READDI(INUNIT,SUBSCH,STBLK*512,BLKCNT*512)
      CALL MOVEUP(SUBSCH,$TEMP*512)
************************************************************************
*                                                                      *
*              START AT BYTE 1 , WORD 1                                *
*                                                                      *
************************************************************************
      $BYTE = 1 ; $WORD = 1
10000 CONTINUE
      $LNAME(3)     = 0
************************************************************************
*                                                                      *
*                                                                      *
*              GET NUMBER OF WORDS THIS DEFN OCCUPIES, AND THE         *
*              DISPLACEMENT OF THE PICTURE, IF THERE IS ONE.           *
*                                                                      *
*                                                                      *
************************************************************************
      $WDCNT = GETBYT(SUBSCH,$BYTE)
      $BYTE = $BYTE + 1
      $SCALD = ISL(GETBYT(SUBSCH,$BYTE),-1)
************************************************************************
*                                                                      *
*              GET THE WORD IN THE SUBSCHEMA THIS APPLIES TO           *
*                                                                      *
************************************************************************
      $LNAME(1)     = BITS(SUBSCH($WORD),16,31)
      $BYTE = $BYTE + 3
      $OUTPT = 4
************************************************************************
*                                                                      *
*              SET FLAG TO INDICATE WHETHER THERE IS A PICTURE OR NOT  *
*                                                                      *
*                                                                      *
************************************************************************
      IF($SCALD.EQ.0)$LNAME(2)      = 0
      IF($SCALD.NE.0)$LNAME(2)     = 1
10    CONTINUE
************************************************************************
*                                                                      *
*                                                                      *
*              GET CHARS UNTIL WE HIT A BLANK. THIS SIGNIFIES THE      *
*              END OF THE NAME.                                        *
*                                                                      *
************************************************************************
      $NXCHR = GETBYT(SUBSCH,$BYTE)
      IF($NXCHR.EQ.64)    GO TO 20
      $LNAME($OUTPT)     = ISL($NXCHR,24)
      $OUTPT = $OUTPT + 1
      $BYTE = $BYTE + 1
      $LNAME(3)     = $LNAME(3)     + 1
      GO TO 10
20    CONTINUE
************************************************************************
*                                                                      *
*                                                                      *
*              IF THERE IS A PICTURE, GET IT. OTHERWISE GET NEXT NAME  *
*                                                                      *
*                                                                      *
       IF($LNAME(2).EQ.0)GO     TO 40
      $BYTE = $BYTE + 2
      $PCCNT =     GETBYT(SUBSCH,$BYTE)
      $LNAME($OUTPT)     = $PCCNT
      $OUTPT = $OUTPT + 1
      $BYTE = $BYTE + 1
      DO 30, $INDEX = 1,$PCCNT
         $NXCHR = GETBYT(SUBSCH,$BYTE)
         $LNAME($OUTPT)     = ISL($NXCHR,24)
         $BYTE = $BYTE + 1
         $OUTPT = $OUTPT + 1
30    CONTINUE
40    CONTINUE
*
*
*        WRITE OUT THE NAMETABLE RECORD WITH THE SUBSCHEMA INCREMENT
*        AS THE KEY
*
*
      CALL WRITNT($LNAME(1),$LNAME(1),$ERROR)
      IF ($ERROR.NE.0)WRITE(TRMNAL,1)$ERROR,$LNAME(1)
1     FORMAT(' ERROR , CODE = ',Z8,' WRITING RECORD WITH KEY ',G)
************************************************************************
*                                                                      *
*              IF WDCOUNT IS ZERO THEN THIS WAS THE LAST NAME.         *
*                                                                      *
************************************************************************
      IF($WDCNT.EQ.0)RETURN
      $WORD = $WORD + $WDCNT
      $BYTE = 4*($WORD-1)+1
      GO TO 10000
      END
      INTEGER FUNCTION GETBYT(ARRAY,BYTE)
************************************************************************
************************************************************************
****                                                                ****
*****        INTEGER FUNCTION GETBYT(ARRAY,BYTE)                   *****
****                                                                ****
************************************************************************
************************************************************************
      WRDNUM = BYTE / 4
      BYTNUM = MOD(BYTE,4)
      IF(BYTNUM.NE.0)WRDNUM = WRDNUM+1
      IF(BYTNUM.EQ.0)BYTNUM = 4
      GETBYT = ISL(ISL(ARRAY(WRDNUM),8*(BYTNUM-1)),-24)
      RETURN
      END
      SUBROUTINE NAMTBL($WORD,$SIZE,$NAME)
************************************************************************
************************************************************************
****                                                                ****
*****        SUBROUTINE NAMTBL($WORD,$SIZE,$NAME)                  *****
****                                                                ****
************************************************************************
************************************************************************
      IMPLICIT LOGICAL(A-Z,$)
      INTEGER $LNAME(65),I,SIZE,$ERROR,X4300/8Z00004300/
      INTEGER $SIZE,$WORD,$NAME(65),$OUTPT,START
       INTEGER INUNIT,OUNIT,TRMNAL
       COMMON / IOUNIT /INUNIT,OUNIT,TRMNAL
         CALL READNT($WORD-1,$LNAME,$ERROR)
         IF($ERROR.EQ.X4300)$SIZE=0;RETURN
         IF($ERROR.NE.0)WRITE(TRMNAL,1)$ERROR,$WORD;RETURN
1        FORMAT(' ERROR , CODE = ',Z8,' READING ELEMENT WITH KEY ',G)
************************************************************************
*                                                                      *
*                                                                      *
*              NOW TRANSFER THE NAME AND PICTURE TO THE                *
*              OUTPUT BUFFER                                           *
*                                                                      *
************************************************************************
      $SIZE = $LNAME(3)
      DO 888 I=4,SIZE
888   $NAME(I-3)=$LNAME(I)
      $OUTPT = $SIZE+1
      $NAME($OUTPT) = 0
      IF($LNAME(2).EQ.0)GOTO       10
      START = SIZE+2
      SIZE = START + $LNAME(SIZE+1)      - 1
      $NAME($OUTPT) = $LNAME(START-1)
      $OUTPT = $OUTPT + 1
      DO 9999 I = START,SIZE
         $NAME($OUTPT) = $LNAME(I)
         $OUTPT = $OUTPT + 1
9999  CONTINUE
10    CONTINUE
      RETURN
      END
      SUBROUTINE MOVEUP($ARRAY,$COUNT)
************************************************************************
************************************************************************
****                                                                ****
*****        SUBROUTINE MOVEUP($ARRAY,$COUNT)                      *****
****                                                                ****
************************************************************************
************************************************************************
*                                                                      *
*                                                                      *
*              THIS SUBROUTINE MOVES MEMORY UP, OVERWRITING THE        *
*              CHECKSUMS PROVIDED BY EDMS.                             *
*                                                                      *
************************************************************************
      IMPLICIT LOGICAL(A-Z,$)
      INTEGER $COUNT,$ARRAY($COUNT)
      INTEGER $INDEX,$IND2
      $INDEX=511
      $IND2 = 511
10    IF($INDEX.GT.$COUNT)RETURN
      $ARRAY($INDEX)=$ARRAY($IND2)
      $INDEX=$INDEX+1
      $IND2=$IND2+1
      IF(MOD($IND2,512).EQ.0)$IND2=$IND2+1
      GO TO 10
      END
      SUBROUTINE READDI(UNIT,BUFFER,SWORD,NWORDS)
************************************************************************
************************************************************************
****                                                                ****
*****        SUBROUTINE READDI(UNIT,BUFFER,SWORD,NWORDS)           *****
****                                                                ****
************************************************************************
************************************************************************
      INTEGER UNIT,NWORDS,SWORD
      INTEGER BUFFER(NWORDS)
      READ DISK UNIT,SWORD,BUFFER
      RETURN
      END
      SUBROUTINE EXPAND(INA,OUTA,COUNT)
************************************************************************
************************************************************************
****                                                                ****
*****        SUBROUTINE EXPAND(INA,OUTA,COUNT)                     *****
****                                                                ****
************************************************************************
************************************************************************
* **********************************************************************
*                                                                      *
*                                                                      *
*     THE SUBROUTINE EXPAND IS PASSED AN INTEGER ARRAY WHICH IS, IN    *
*     REALITY, A BYTE STRING , WITH A CHARACTER COUNT AS THE FIRST     *
*     BYTE OF THE FIRST WORD. IT TAKES THIS ARRAY AND EXPANDS THE      *
*     BYTE STRING INTO A1 FORMAT FOR OUTPUT BY FORTRAN, PLACEING       *
*     NUMBER OF CHARACTERS IN THE BYTE STRING.                         *
*                                                                      *
*                                                                      *
* **********************************************************************
      IMPLICIT LOGICAL(A-Z,$)
      INTEGER INA(8),OUTA(31),$IND1,$IND2,$IND3,$IND4,COUNT
      $IND1=1
      $IND2=1
      $IND4=ISL(INA(1),-24)
      COUNT  = $IND4
      DO 99, $IND3 = 1,$IND4
      $IND1 = 1 + $IND1
      IF($IND1.GT.4)$IND1=1;$IND2=$IND2+1
      OUTA($IND3) = ISL(ISL(INA($IND2),-8*(4-$IND1)),24)
99    CONTINUE
      RETURN
      END
      SUBROUTINE DMPREC($RETRN)
************************************************************************
************************************************************************
****                                                                ****
*****        SUBROUTINE DMPREC                                     *****
****                                                                ****
************************************************************************
************************************************************************
      IMPLICIT LOGICAL(A-Z,$)
************************************************************************
*                                                                      *
*                                                                      *
*        OUTPUT BUFFER FOR REFORMATTED RECORD                          *
*                                                                      *
************************************************************************
      INTEGER BUFFER
      COMMON / OUTPUT / BUFFER(300)
*                                                                      *
*        SUBSCHEMA BUFFER .                                            *
*                                                                      *
************************************************************************
      INTEGER SUBSCH,CURARA
      COMMON / SSCH   / SUBSCH(15360),CURARA
************************************************************************
      INTEGER INUNIT,OUNIT,TRMNAL
      COMMON / IOUNIT / INUNIT,OUNIT,TRMNAL
      INTEGER $STATS,$SIZE,$INDEX
      CALL BUFFER OUT(OUNIT,0,BUFFER,300,$STATS,$SIZE)
*
*
*        IF THE CALLING SUBROUTINE DOESNT WANT THE OUTPUT BUFFER
*        ZEROED, THEN RETURN
*
*
      IF($RETRN)RETURN
      DO 99, $INDEX = 1,300
         BUFFER($INDEX) = 0
99    CONTINUE
      RETURN
      END
      INTEGER FUNCTION BITS($WORD,$LEFT,$RIGHT)
************************************************************************
************************************************************************
****                                                                ****
*****        INTEGER FUNCTION BITS($WORD,$LEFT,$RIGHT)             *****
****                                                                ****
************************************************************************
************************************************************************
********************************************************************** *
      IMPLICIT LOGICAL(A-Z,$)
      INTEGER $LEFT,$RIGHT,$WORD
************************************************************************
*                                                                      *
*        BITS BETWEEN $LEFT AND $RIGHT OUT OF $WORD                    *
*                                                                      *
************************************************************************
      BITS = ISL(ISL($WORD,$LEFT),($RIGHT-$LEFT+1)-32)
      RETURN
      END
      LOGICAL FUNCTION BITSET(WORD,BITNUM)
************************************************************************
************************************************************************
****                                                                ****
*****        LOGICAL FUNCTION BITSET(WORD,BITNUM)                  *****
****                                                                ****
************************************************************************
************************************************************************
      IMPLICIT LOGICAL (A-Z,$)
      INTEGER BIT,WORD,BITNUM
************************************************************************
*                                                                      *
*        CONSTANT COMMON BLOCK                                         *
*                                                                      *
************************************************************************
      LOGICAL TRUE,FALSE
      COMMON / CONSTS / BIT(32),TRUE,FALSE
************************************************************************
*                                                                      *
*        IF BIT NUMBER "BITNUM" IS SET, RETURN TRUE,                   *
*        ELSE RETURN FALSE                                             *
*                                                                      *
************************************************************************
      RETURN
      END
      SUBROUTINE MAIN
************************************************************************
*                                                                      *
*                                                                      *
*        BUFFER FOR NAME RECORD FROM NAME TABLE                        *
*                                                                      *
************************************************************************
************************************************************************
*                                                                      *
*                                                                      *
*        OUTPUT BUFFER FOR REFORMATTED RECORD                          *
*                                                                      *
************************************************************************
      INTEGER BUFFER
      COMMON / OUTPUT / BUFFER(300)
************************************************************************
*                                                                      *
*        SUBSCHEMA BUFFER .                                            *
*                                                                      *
************************************************************************
      INTEGER SUBSCH,CURARA
      COMMON / SSCH   / SUBSCH(15360),CURARA
************************************************************************
*                                                                      *
*        INPUT-OUTPUT UNITS                                            *
*     INUNIT = F:1                                                     *
*     TRMNAL = F:3
*                                                                      *
************************************************************************
      INTEGER INUNIT,OUNIT,TRMNAL
      COMMON / IOUNIT / INUNIT,OUNIT,TRMNAL
************************************************************************
*                                                                      *
*        CONSTANTS USED THROUGHOUT THE PROGRAM                         *
*                                                                      *
************************************************************************
      INTEGER BIT
      LOGICAL TRUE,FALSE
      COMMON / CONSTS / BIT(32),TRUE,FALSE
      INTEGER NTBLK,$INDEX,SSSIZE,NTCT,PSBLK,PSCT,SSBLK,SSCT
      INUNIT = 1
      OUNIT  = 2
      TRMNAL = 3
*
*
*        OPEN NAME TABLE SCRATCH FILE
*
*
      CALL OPENNT($ERROR)
      IF($ERROR.NE.0)WRITE(TRMNAL,1)$ERROR;STOP 'DEAD'
1     FORMAT(' ERROR ',Z8,' OPENING NAME TABLE SCRATCH FILE')
*
*
*        READ IN DIRECTORY GRANULE AND EXTRACT RELEVANT INFO
*
*
      CALL READDI(INUNIT,SUBSCH,0,512)
      NTBLK = SUBSCH(6);NTCT = SUBSCH(7)
      PSBLK = SUBSCH(4);PSCT = SUBSCH(5)
      SSBLK = SUBSCH(2);SSCT = SUBSCH(3)
      SSSIZE = SUBSCH(8)
      DO 99 , $INDEX = 1,300
99    BUFFER($INDEX) = 0
*
*
*        BREAK UP THE NAME TABLE
*
*
      CALL BRKTBL(NTBLK,NTCT)
      CURARA = 0
*
*        DEFINE PASSWORDS FOR SUBSCHEMA
*
      CALL PASDEF(PSBLK,PSCT)
      IF(SSCT.GT.30)STOP'ATTEMPT TO READ SUBSCHEMA LARGER THAN 30 PAGES'
*
*
*        CHECKSUMS.
*
*
      CALL READDI(INUNIT,SUBSCH,SSBLK*512,SSCT*512)
      CALL MOVEUP(SUBSCH,SSSIZE)
*
*
*        CALL SUBSCHEMA DEFINITION SUBROUTINE. THIS LINKS OFF TO
*        THE REST OF THE PROGRAM
*
*
      CALL SUBDEF(1)
      STOP 'REFORMATTING THE SUBSCHEMA.'
      END
*
*
*
*
*
*
*
*                    RECORD DEFINITIONS AS OF 19 78 10 31
*                                             1979 07 19/CHS
*                    ====================================
*
*
*              AREA DEFINITION
*              ===============
*
*  WORD #        MEANING
*  ------        -------
*
*  2           CODE FOR AREA DEFINITION
*  3           SUBCODE (ALWAYS ZERO)
*  4           WORKING STORAGE INCREMENT
*  5           NUMBER OF PAGES IN THE AREA
*  6           AREA NUMBER
*  7           INVENTORY PERCENT
*  8           0 IF NO CHECKSUM ON AREA,1 IF AREA IS CHECKSUMMED
*  9           NUMBER OF BITS PER LINE NUMBER IN THE AREA
*  10          0 IF AREA IS NOT ENCIPHERED, 1 IF IT IS.
*  11          0 IF AREA IS NOT TO HAVE JOURNALING, 1 IF IT IS
*  12          FILL PERCENTAGE
*  13          INDEX KEY SIZE IN BYTES
*  14          PAGE SIZE IN WORDS
*  15          OVERFLOW MINIMUM PAGE
*  16          OVERFLOW MAXIMUM PAGE
*  17          NUMBER OF CHARACTERS IN AREA NAME
*  18          AREA NAME IN "A1" FORMAT.
*
*              GROUP DEFINITION
*              ================
*
* WORD #         MEANING
* ------         -------
*
*  2           CODE FOR GROUP DEFINITION
*  4           GROUP NUMBER
*  5           WORKING STORAGE INCREMENT OF GROUP
*  6           1 IF STORED RELATIVE TO A STORAGE SET, 0 IF NOT.
*  7           RETRIEVE LOCK TO GROUP
*  8           UPDATE LOCK TO GROUP
*  9           GROUP TYPE :   0) VIA SET
*                             1) DIRECT GROUP
*                             2) CALC   GROUP
*                             3) INDEXED GROUP
*  10          DATA BASE GROUP SIZE IN WORDS
*  11          WORKING STORAGE SIZE IN WORDS
*  12          PAGE RANGE MINIMUM ( -1  IF NO PAGE RANGE SPECIFIED)
*  13          PAGE RANGE MAXIMUM (-1 IF NO PAGE RANGE SPECIFIED)
*  14          PAGE RANGE PRIME VALUE (-1 IF NOT SPECIFIED)
*  15          NUMBER OF CONTROL ITEMS FOR THIS GROUP
*  16          NUMBER OF DATA BYTES IN GROUP
*  17          FLAG TO INDICATE IF THIS IS A MANUAL MEMBER
*  18          FLAG TO INDICATE IF STATISTICS ARE TO BE
*              GATHERED FOR THIS GROUP
*  19          1 IF DUPLICATES ALLOWED AND THIS IS CALC GRP
*  20          NUMBER OF CHARACTERS IN NAME
*  21 - ??     NAME IN "A1" FORMAT
*  ??+1        NUMBER OF SETS
*  ??+2 - ???  SET NUMBERS
*
*              OWNER DEFINITION
*              ================
*
* WORD #         MEANING
* ------         -------
*
*  2           CODE FOR OWNER (SET) DEFINITION
*  3            SUBCODE (ALWAYS ZERO)
*  4           SET NUMBER
*  5           OWNER GROUP
*  6           SET ORDER (CODES AS IN EDMS MANUAL)
*  7           OWNER TYPE (0-GROUP,1-AREA)
*  8           POSITION NEXT
*  9           POSITION PRIOR
*  10          FLAG TO INDICATE IF STATS TO BE GATHERED
*              FOR THIS GROUP
*  12 - ?      NAME IN "A1" FORMAT
*  ? + 1       SIZE OF SET NAME
*  ? + 2 - ??  SET NAME
*  ??+1        NUMBER OF MEMBERS IN SET
*  ??+2 - ???  MEMBER LIST
*              WHERE "MEMBER LIST" IS:
*                 1) MEMBER GROUP NUMBER
*                 2) MEMBER INCLUSION MODE (1 IF MANUAL ALLOWED)
*                 3) POSITION NEXT
*                 4) POSITION PRIOR
*                 5) POSITION HEAD
*
*
*
*              MEMBER DEFINITION
*              =================
*
* WORD #         MEANING
* ------         -------
*
*  2           CODE FOR MEMBER DEFINITION
*  3           SUBCODE ( ALWAYS 10)
*  4           SET   NUMBER
*  5           GROUP NUMBER
*  6           POSITION NEXT
*  7           POSITION PRIOR
*  8           POSITION HEAD
*  9           1 IF THERE IS AN ALIAS FOR THIS SET
*  10          1 IF THIS IS OPTIONAL MEMBER
*  11          1 IF THIS IS MANUAL MEMBER
*  12          1 IF THIS IS A PAGESET MEMBER
*  13          1 IF THIS IS A CALCSET MEMBER
*  14          1 IF GROUP NUMBER IS MAJOR SORT KEY
*              2 IF GROUP NUMBER IS MINOR SORT KEY
*  15          SET ORDER:
*              0 IMPLIES LAST
*              1 IMPLIES PRIOR
*              4 IMPLIES SORTED
*              8 IMPLIES FIRST
*              9 IMPLIES NEXT
*              6 IMPLIES SORTED BY GROUP NUMBER
*  16          0 IF DUPLICATES NOT ALLOWED
*              1 IF DUPLICATES FIRST
*              2 IF DUPLICATES LAST
*  17          1 IF SELECTION IS CURRENT
*              0 IF LOCATION MODE OF OWNER
*  18          1 IF THIS IS A STORAGE SET FOR THE GROUP
*  19          GROUP NUMBER THIS IS STORAGE SET FOR
*  20          1 IF THIS IS A PRIME RETRIEVAL SET
*  21          1 IF CONTROL ITEMS HAVE BEEN OMITTED
*  22          NUMBER OF ALIAS DEFN'S FOLLOWING
*  23          NUMBER OF CHARACTERS IN GROUP NAME
*  24-?        GROUP NAME
*  ?+1         NUMBER OF KEY DEFINITIONS
*
*              WHERE KEY DEFINITIONS CONSIST OF
*               1) KEY TYPE (4-ASCENDING,6-DESCENDING)
*               2) NUMBER OF CHARACTERS IN KEY NAME
*               3) KEY NAME
* ?+2 - ??     SORT KEY DEFINITIONS
*              ITEM DEFINITION
*              ===============
*
* WORD #         MEANING
* ------         -------
*
*  2            CODE FOR ITEM DEFINITIONS (02)
*  4           GROUP NUMBER THIS ITEM BELONGS TO
*  3           SUBCODE ( 30 FOR NON-CONTROL ITEMS:       25 FOR CONTROL    ITEMS: )
*  5             0 FOR NON-CONTROL ITEMS                  NUMBER OF CNTRL ITEMS IN GRP
*                NON-ZERO FOR CNTRL ITEMS
*                SEE WORD 6 CONTROL TYPES FOR NON-
*                ZERO POSSIBILITIES
*  6           ITEM TYPE:                               CONTROL TYPE:
*                 0 - SIGNED NUMBER                                 2 - CALC
*                 1 - ALPHANUMERIC                                  4 - ASC SORT KEY
*                 2 - NUMERIC                                       6 - DSC SORT KEY
*                 3 - ALPHABETIC                                    8 - INDEXED
*                 4 - BINARY
*                 5 - FLOATING SHORT
*                 6 - FLOATING LONG
*                 7 - PACKED
*  7           1 IF ITEM IS INVERTED                    FILE INCREMENT
*  8           WORKING STORAGE INCREMENT OF ITEM        POSITION OF ITEM IN CHAIN
*  10          FILE INCREMENT OF ITEM
*  11          RETRIEVE LOCK                            ABOVE FOUR FIELDS
*  12          UPDATE LOCK                              REPEAT FOR # OF ITEMS IN GRP
*  13          NUMBER OF CHARACTERS IN NAME
*  14 - ?      NAME IN "A1" FORMAT
*  ?+1         NUMBER OF CHARACTERS IN PICTURE
*  ?+2 - ??    PICTURE IN "A1" FORMAT
*  ??+1  - ??? CHECK VALUES FOR ITEM.
*
*              SUBSCHEMA  DEFINITION
*              =====================
*
* WORD #         MEANING
* ------         -------
*
*  2           CODE FOR SUBSCHEMA DEF'N
*  3           SUBCODE (ALWAYS ZERO)
*  4           YEAR SUBSCHEMA WAS CREATED
*  5           DAY OF YEAR SUBSCHEMA WAS CREATED
*  6           SIZE OF SET POINTERS (3 OR 5 BYTES)
*  7           1 IF SUBSCHEMA WAS CREATED USING "COMPONENTS  ARE ALL"
*
*              PASSWORD DEFINITION
*              ===================
*
* WORD #         MEANING
* ------         -------
*
*  2           CODE FOR PASSWORD DEFINITION
*  3           SUBCODE (ALWAYS ZERO)
*  4-5         PASSWORD
*  6-13        RETRIEVE AUTHORITY INDICATORS
*  14-20       UPDATE AUTHORITY INDICATORS
*
*              INDEXED SEQUENTIAL DEFINITION
*              =============================
*
* WORD #         MEANING
* ------         -------
*
*  2           CODE FOR INDEXED-SEQUENTIAL DEF'N
*  4           1 IF THIS IS AN INDEX LEVEL DEF'N, 0 IF OVERFLOW RANGE
*  5           INDEX LEVEL NUMBER
*  6           BEGINNING PAGE NUMBER
*  7           ENDING PAGE NUMBER
*
*              INVERT ITEM DEFINITION
*              ======================
*
*
*  WORD #        MEANING
*  ------        -------
*
*
*  2           CODE FOR INVERT DEFINITION
*  3           SUBCODE (40)
*  4           INVERT ITEM NUMBER (INVERT GROUP NUMBER)
*  5           PAGE RANGE MINIMUM VALUE ( 0 IF NOT SPECIFIED)
*  6           PAGE RANGE MAXIMUM VALUE ( 0 IF NOT SPECIFIED )
*  6           PAGE RANGE PRIME VALUE ( 0 IF NOT THERE)
*  8           1 IF DUPLICATES ALLOWED, 0 IF NOT
*  9           COUNT OF CHARACTERS IN ITEM NAME
* 10-?         ITEM NAME
*
*           ALIAS RECORD
*           ============
* WORD #       MEANING
* ======       =======
*
* 1               AREA NUMBER
* 2               MAJOR CODE (MEMCOD)
* 3               SUBCODE (ALCODE)
* 4               SET NUMBER OF MEMBER DEFINITON
* 5               SIZE OF ITEM NAME
* 6               WORD PACKED ITEM NAME
*
*
*              VIA/STORAGE SET DEFINITION RECORD
*              =================================
*
* WORD #          MEANING
* ======          =======
*
* 1               AREA NUMBER
* 2               CODE (02)
* 3               SUBCODE (10)
* 4               GROUP NUMBER
* 5               UNPACKED TEXTC SET NAME
*
*
*
*
*                            NOTE
*                            ====
*
*  ALL RECORDS CONTAIN THE CURRENT AREA NUMBER IN WORD #1
*
*                            DEFINITION FOR NAME TABLE
*                            ==========================
*
*                            19 78 06 10
*                            -----------
*
* WORD #         MEANING
* ------         -------
*
*  2          1 IF THERE IS A PICTURE, 0 IF NOT
*  3          NUMBER OF CHARACTERS IN NAME
*  4-?        NAME IN "A1" FORMAT
*  ?+1        NUMBER IF CHARACTERS IN PICTURE, IF THERE IS ONE
*  ?+2-??     PICTURE IN "A1" FORMAT
*
      WRITE (108,40)
40    FORMAT (' EVAL_1 A01 HERE')
      WRITE (108,50)
50    FORMAT (' REFORMATTING THE SUBSCHEMA TO EVAL_WF1')
      CALL MAIN
      END
