      IMPLICIT INTEGER (A-Z)
      COMMON /QSCCB/QSCCB(130)
      COMMON /SCHEMA/MX(8192)
      COMMON /TABLE/NBGROUP,NBSET,NBCARD
      COMMON /GRPTABLE/GRPTABLE(100)
      COMMON /INPUT/X(72)
      COMMON /COMPACT1/CMOVE(20)
      COMMON /CCB/CCB(13),SETS,WSISET(5),NAMESSET(5),QSPAREA(2)
     1,HEADER(2),WSI(4),ITEMNAME(12),MASTERS(20)
      COMMON /LISTING/QUERY,TOPOLOG,SORT,COPY,ER
      COMMON /SUBAREAS/AREANUMBER(65)
      INTEGER AREA(2)
      INTEGER KEYFFF(2)
      INTEGER SUB(2)
      DATA KEYFFF/8H##FNAMES/
      DATA SUB/8HSUB#AREA/
      DATA CCB1/4HCCB /
      DATA ONE,TWO,THREE/4H1   ,4H2   ,4H3   /
      DATA ZERO/4H0     /
      DATA SET/4HSET-/
      DATA AREA/8HAREA-TAB/
      DATA WSIKEY/4HWSI /
C
C QSP USES THE DMS DATA BASE DEFINED BY THIS DDL
C

C  SCHEMA IS QSPSMA.
C  AREA IS QSP-AREA CONTAINS 50 PAGES
C      ; NUMBER IS 1
C      ; ENCIPHERING IS NOT REQUIRED
C      ; CHECKSUM IS REQUIRED.
C  GROUP IS HEADER
C      ; WITHIN QSP-AREA
C      ; LOCATION IS CALC USING AREANUMB DUPLICATES NOT ALLOWED
C      ; NUMBER IS 1.
C      AREANUMB; TYPE IS BINARY.
C  GROUP IS WSI
C      ; WITHIN QSP-AREA
C      ; LOCATION MODE IS VIA WSISET
C      ; NUMBER IS 2.
C      POINTER; TYPE IS BINARY.
C      WORKING; TYPE IS BINARY.
C      TYPES  ; TYPE IS BINARY.
C  GROUP IS ITEMNAME
C      ; WITHIN QSP-AREA
C      ; LOCATION IS CALC USING ITEMS DUPLICATES ARE ALLOWED
C      ; NUMBER IS 3.
C      ITEMS; PIC X(32).
C      POINTER1; TYPE IS BINARY.
C      WORKING1; TYPE IS BINARY.
C      TYPES1 ; TYPE IS BINARY.
C  SET IS WSISET
C      ; OWNER IS HEADER
C      ; ORDER IS SORTED.
C   MEMBER IS WSI
C      ; INCLUSION IS AUTOMATIC
C      ; SELECTION IS CURRENT
C      ; ASCENDING KEY IS WORKING DUPLICATES ARE LAST.
C  SET IS NAMESSET
C      ; OWNER IS HEADER
C      ; ORDER IS SORTED.
C   MEMBER IS ITEMNAME
C      ; INCLUSION IS AUTOMATIC
C      ; SELECTION IS CURRENT
C      ; ASCENDING KEY IS ITEMS DUPLICATES ARE LAST.
C  END.
C
C LISTING PRODUCED BY QSP
C
C   DATABASE OPENED IF ZERO:  0
C                                          WSI DEC WSI HEX  SSCH PTR  TYPE
C                                          ------- -------  --------  ----
C         01  SET-TABLES COMP.                 13   0000000D  0000000008
C             02  WSISET.                      14   0000000E  0000001A 3
C             02  NAMESSET.                    19   00000013  0000001E 3
C         01  AREA-TABLE.
C             02  QSP-AREA PIC X(4) VALUE SP   24   00000018  00000003 1
C         01  HEADER.                          26   0000001A  00000011 2
C             02  AREANUMB COMP.              104   00000068  00000022 5
C             02  CURR-001 COMP.              108   0000006C  00000000 5
C         01  WSI.                             28   0000001C  00000027 2
C             02  POINTER COMP.               112   00000070  0000002D 5
C             02  WORKING COMP.               116   00000074  00000032 5
C             02  TYPES COMP.                 120   00000078  00000037 5
C             02  CURR-002 COMP.              124   0000007C  00000000 5
C         01  ITEMNAME.                        32   00000020  00000047 2
C             02  ITEMS PIC X(32).            128   00000080  00000050 5
C             02  POINTER1 COMP.              160   000000A0  00000055 5
C             02  WORKING1 COMP.              164   000000A4  0000005A 5
C             02  TYPES1 COMP.                168   000000A8  0000005F 5
C             02  CURR-003 COMP.              172   000000AC  00000000 5
C         01  AREA-MASTERS-01 COMP.            44   0000002C  0000006F 2
C             02  CURR-1000.                  176   000000B0  00000000 5
C             02  CALCSET.                     45   0000002D  00000075 3
C  LEVL GROUP NAMES      SET NAMES         ACCESS METH
C     1 HEADER
C     2 WSI              WSISET            1
C     2 ITEMNAME         NAMESSET          1
C                                          WSI DEC WSI HEX  SSCH PTR  TYPE
C                                          ------- -------  --------  ----
C  ***SORTED LISTING.
C  **********TYPES: 1  AREA, 2 GROUPS, 3 SETS, 5 ITEMS.
C
C   AREA-MASTERS-01                            44   0000002C  0000006F 2
C   AREANUMB                                  104   00000068  00000022 5
C   CALCSET                                    45   0000002D  00000075 3
C   CURR-001                                  108   0000006C  00000000 5
C   CURR-002                                  124   0000007C  00000000 5
C   CURR-003                                  172   000000AC  00000000 5
C   CURR-1000                                 176   000000B0  00000000 5
C   HEADER                                     26   0000001A  00000011 2
C   ITEMNAME                                   32   00000020  00000047 2
C   ITEMS                                     128   00000080  00000050 5
C   NAMESSET                                   19   00000013  0000001E 3
C   POINTER                                   112   00000070  0000002D 5
C   POINTER1                                  160   000000A0  00000055 5
C   QSP-AREA                                   24   00000018  00000003 1
C   TYPES                                     120   00000078  00000037 5
C   TYPES1                                    168   000000A8  0000005F 5
C   WORKING                                   116   00000074  00000032 5
C   WORKING1                                  164   000000A4  0000005A 5
C   WSI                                        28   0000001C  00000027 2
C   WSISET                                     14   0000000E  0000001A 3
C
C HERE WE OPEN THE "QSP-AREA" FILE WHICH IS A EDMS DATABASE.
C THE FOLLOWING SET ARE NEEDED:
C     SET F:SSCH DP/QSP-SUB
C     SET F:DB01 DP/QSP-AREA
C
C IF THE FILE "QSP-AREA" WAS PREVIOUSLY USED THE HEADER GROUP
C IS DELETED WHICH IS EQUIVALENT TO A REINITIALIZATION.
C
      CALL MES (' QSP D00 HERE',13)
      CCB(1)=10
      CCB(13)=1
      CALL OPENUPD(CCB,QSPAREA)
      CALL MES (' QSP-AREA OPENED',16)
      HEADER(1)=1
      CALL FINDG(HEADER(1))
      IF(CCB(8).EQ.0) CALL DELETE(HEADER(1))
      CALL STORE(HEADER(1))
 3    CONTINUE
C
C THE SUSCHEMA FILE OF THE DATABASE FOR WHICH WE ARE CREATING
C THE QUERYSCHEMA IS READ INTO BUFFER MX
C THE FOLLOWING SET IS NEEDED:
C
C SET F:7/SUBSCHEMA;IN
C
      NBSET=0
       NBGROUP=-1
C
C WE READ THE SCHEMA THE FIRST PAGE IS NOT USED
C
      CALL BUFFER IN(7,1,MX,512,IK1,NB1)
      NBPAGES=MX(3)
      IF(NBPAGES.GT.16) CALL MES('***SUBSCHEMA TOO BIG',24);CALL CLOSEDB
     1; STOP 12
C
C NB1 IS THE NUMBER OF WORDS READ
C IK1 IS THE ERROR MESSAGE 1,READ NOT COMPLETED
C                          2 AND 4 OK
C                          3 END OF READING
C
  10  GOTO(10,15,900,15),IK1
  15  J=1
  16  CONTINUE
      CALL BUFFER IN(7,1,MX(J),512,IK1,NB1)
  20  GOTO(20,25,40,25),IK1
C
C IF THE FIRST WORD OF THE BYTE OF THE SCHEMA IS NOT 07 THE
C FILE IS NOT A SUBSCHEMA. WE ABORT
C
  25  IF(J.EQ.1 .AND. IFIELD(MX(1),0,8).NE.7) GOTO 900
      J=J+511
      IF(J.GT.NBPAGES*511) GOTO 40
      GOTO 16
C
C THE SCHEMA IS NOW IN CORE. STARTING AT MX(1)
C
   40  CONTINUE
C
C THE USER IS REQUESTED FOR TWO LISTINGS:
C A NEW COPY FILE LISTING WITH WORKING STORAGE INCREMENT
C A SORTED LISTING BY NAME WITH AN EXTRA POINTER TO THE SUBSCHEMA
C
      COPY=0
C     CALL QUAANSB('IF YOU DO NOT WANT A COPY FILE LISTING TYPE 0: ',
C    150,4,COPY,0,300S,1)
 300  CONTINUE
C
      SORT=1
C     CALL QUAANSB('IF YOU DO NOT WANT A SORTED DDL NAMES TYPE 0: ',
C    150,4,SORT,0,301S,1)
 301  CONTINUE
C
C THE TOPOLOGY TABLE IS STORED INTO THE QS FILE
C NOT SET ARE NECESSARRY.
C
      TOPOLOG=1
C     CALL QUAANSB('IF YOU DO NOT NEED THE TOPOLOGY TABLE TYPE 0: ',
C    150,4,TOPOLOG,0,303S,1)
 303  CONTINUE
C
C THE QUERY SCHEMA FILE IS NOW OPENED.
C THE FOLLOWING SET IS NEEDED:
C
C SET F:1/QSFILE
C
      QUERY=1
C     CALL QUAANSB('IF YOU DO NOT NEED THE QUERY SCHEMA FILE TYPE 0: ',
C    150,4,QUERY,0,304S,1)
 304  CONTINUE
      IF(QUERY.NE.1) GOTO 305
      CALL OPENDCB(1,2,8,302S,ER)
      CALL RINIT(1,144)
 305  CONTINUE
       DO 41 I=1,130
       QSCCB(I)=0
   41  CONTINUE
       AREANUMBER(1)=0
       CALL GETSFN(AREANUMBER(2))
       IF(QUERY.EQ.1) CALL RWRITE(1,AREANUMBER(2),64,KEYFFF,8,302S)
       CALL SUBSCHEMA
       IF(QSCCB(1).NE.0) GOTO 900
   42  CALL AREALK
       IF(QSCCB(1).EQ.1) GOTO 100
       CALL ENTERAREA
       AREANUMBER(1)=AREANUMBER(1)+1
       L=AREANUMBER(1)*2
       AREANUMBER(L)=QSCCB(3)
       AREANUMBER(L+1)=IFIELD(QSCCB(33),0,8)
   43  CALL GROUPLK
       IF(QSCCB(1).EQ.1) GOTO 42
       CALL ENTERGROUP
      CALL ENTERCUR
   44  CALL ITEMLK
       IF(QSCCB(1).EQ.1) GOTO 45
       CALL ENTERITEM
       GOTO 44
   45  CALL OWNERLK
       IF(QSCCB(1).EQ.1) GOTO 43
       CALL ENTERSET
       GOTO 45
 100   CONTINUE
       IF(QUERY.EQ.1) CALL RWRITE(1,AREANUMBER,(L+1)*4,SUB,8,302S)
C
C THE TABLES ARE SET AS FOLLOW
C GROUP TABLE AND ITEM TABLE ARE ONE TABLE:
C NAME(2)--SCHEMA PTR--WSI--USED OR NOT USED(1/0)
C
C SET TABLE AS SAME FORMAT.
C
C WHEN WE ARRIVE HERE WE ARE READY TO READ THE COBOL FILE.
C
      IF(COPY.EQ.1) WRITE(108,700)
      NCARD=0
      CALL FINDG(HEADER)
  101 NCARD=NCARD+1
      READ(2,1,END=8000)(X(L),L=1,72)
      I=1
      CALL BLANC(I)
      IF(X(I).EQ.ZERO.AND.X(I+1).EQ.ONE)GOTO 1000
      IF(X(I).EQ.ZERO.AND.X(I+1).EQ.TWO) GOTO 2000
      IF(X(I).EQ.ZERO.AND.X(I+1).EQ.THREE) GOTO 3000
      WRITE(108,501)NCARD,X
 501  FORMAT('BAD COBOL CARD NUMBER:',I4,2X,72A1)
      STOP 501
 1000 I=I+2
      CALL BLANC(I)
      CALL COMPACT(CMOVE,I)
      IF(NCARD.EQ.1 .AND.CMOVE(1).NE.CCB1) GOTO 500
      IF(NCARD.NE.1) GOTO 1001
      DO 1002 I=1,11
      READ(2,1,END=8000)(X(L),L=1,72)
 1002 CONTINUE
      NCARD=12
      GO TO 101
 1    FORMAT(72A1)
C
 1001 CONTINUE
      CALL MASTER
      GOTO 1005
 1005 CONTINUE
C
C AREA DEFINITION
      IF(CMOVE(1).NE.AREA(1)) GOTO 500
 700  FORMAT(40X,'WSI DEC WSI HEX  SSCH PTR  TYPE',/,40X,
     1           '------- -------  --------  ----')
      IF(COPY.EQ.1)WRITE(108,503)(X(L),L=1,50)
 503  FORMAT(50A1)
      CALL AREATABLE
      CALL AREAMASTER
      IF(WSI(3).EQ.3) WSI(2)=WSI(2)+20
      WRITE(108,1080) WSI(2)/4
 1080 FORMAT(/,'WORKING STORAGE NEEDED:',I5,/)
      IF(QUERY.EQ.1)CALL RWRITE(1,WSI(2)/4,4,WSIKEY,4,302S)
      IF(TOPOLOG.EQ.1.AND.QUERY.EQ.1)
     1OUTPUT '                 TOPOLOGY TABLE.';OUTPUT ' ';
     1CALL TOPOLOGY
      IF(SORT.EQ.1) WRITE(108,700); CALL PRINT
      CALL CLOSEDB
      CALL MES ('QSP_WF1 IS READY FOR INPUT TO IDDP',34)
      STOP 'QSP FINISHED'
 900  WRITE(108,901)
 901  FORMAT('***BAD SUBSCHEMA FILE.')
      CALL CLOSEDB
      STOP
 8000 CONTINUE
 2000 CONTINUE
 3000 CONTINUE
  500 CONTINUE
      WRITE(108,502)
 502  FORMAT('***BAD COPY FILE.')
      CALL CLOSEDB
      STOP
 302  CONTINUE
      WRITE(108,310)ER
      CALL CLOSEDB
      STOP
 310  FORMAT('***CANNOT OPEN QUERY THE SCHEMA FILE ERROR NO: ',I2)
      END
C*********************************************************
      SUBROUTINE ENTERGROUP
      IMPLICIT INTEGER (A-Z)
      COMMON /LISTING/QUERY,TOPOLOG,SORT,COPY,ER
      COMMON /QSCCB/QSCCB(130)
      COMMON /SCHEMA/MX(4096)
      COMMON /TABLE/NBGROUP,NBSET,NBCARD
      COMMON /GRPTABLE/GRPTABLE(100)
      COMMON /CCB/CCB(13),SETS,WSISET(10),AREA(4),WSI,WORKING,TYPE
      EQUIVALENCE(WSI,POINTER)
       IF(IFIELD(QSCCB(62),0,10) .GE.1001) RETURN
      NBGROUP=NBGROUP+1
      I=NBGROUP*5+1
      GRPTABLE(I+2)=QSCCB(5)
      GRPTABLE(I+3)=IFIELD(QSCCB(61),15,17)*4
      TYPE=2
      GOTO 100
C
      ENTRY ENTERCUR
      NBGROUP=NBGROUP+1
      I=NBGROUP*5+1
      GRPTABLE(I+2)=0
      GRPTABLE(I+3)=(IFIELD(QSCCB(61),15,17)+IFIELD(QSCCB(66),0,10))*4
      TYPE=5
      GOTO 100
      ENTRY ENTERITEM
C CHECKING FOR CONTROL ITEMS
      IF(IFIELD(QSCCB(75),15,17).NE.QSCCB(5)) GOTO 100
      NBGROUP=NBGROUP+1
      I=NBGROUP*5+1
      GRPTABLE(I+2)=QSCCB(6)
      GRPTABLE(I+3)=IFIELD(QSCCB(71),15,17)
      TYPE=5
      GOTO 100
C
      ENTRY ENTERSET
      NBGROUP=NBGROUP+1
      I=NBGROUP*5+1
      GRPTABLE(I+2)=QSCCB(10)
      GRPTABLE(I+3)=IFIELD(QSCCB(111),15,17)*4
      TYPE=3
      GOTO 100
C
      ENTRY ENTERAREA
      NBGROUP=NBGROUP+1
      I=NBGROUP*5+1
      GRPTABLE(I+2)=QSCCB(3)
      GRPTABLE(I+3)=IFIELD(QSCCB(31),15,17)*4
      TYPE=1
      GOTO 100
 100  CONTINUE
      POINTER=GRPTABLE(I+2)
      WORKING=GRPTABLE(I+3)
      CALL STORE(WSI)
       NBGROUP=NBGROUP-1
C     WRITE(108,101)IFIELD(CCB(1),0,8),IFIELD(CCB(1),8,24),CCB(2)
C    1,CCB(3),CCB(4),CCB(8),POINTER,WORKING,TYPE
 101  FORMAT(1X,I2,1X,I6,1X,2A4,1X,A3,1X,I3,Z10,Z10,I2)
      RETURN
      END
C**********************************************************
      SUBROUTINE MASTER
      IMPLICIT INTEGER (A-Z)
      COMMON /LISTING/QUERY,TOPOLOG,SORT,COPY,ER
      COMMON /BUFDUPL/BUF1(100)
      COMMON /INPUT/X(72)
     1AREAMSTR(10)
      COMMON /COMPACT1/CMOVE(20)
      INTEGER BLANC1(8)
      DATA BLANC1/8*4H     /
      DATA TWO/4H2    /
      CALL FMVC(ITEM,0,BLANC1,0,32)
      CALL FMVC(ITEM,0,CMOVE,0,32)
      ITEM(9)=0
      ITEM(10)=13
      ITEM(11)=0
      CALL STORE(ITEM)
      NBCARD=NBCARD+1
      IF(COPY.EQ.1)WRITE(108,1)(X(L),L=1,40),ITEM(10),ITEM(10),ITEM(9),ITEM(11)
 1    FORMAT(40A1,I6,1X,2Z10,I2)
 2    CONTINUE
      NBCARD=NBCARD+1
      READ(2,3,END=8000)(X(L),L=1,72)
 3    FORMAT(72A1)
      I=1
      CALL BLANC(I)
      IF(X(I+1).NE.TWO) GOTO 4
      I=I+2
      CALL BLANC(I)
      CALL FMVC(ITEM,0,BLANC1,0,32)
      CALL COMPACT(ITEM,I)
      CALL FINDN(SET(2))
      CALL GET(WSI)
      ITEM(9)=WSI(1)
      ITEM(10)=WSI(2)/4
      ITEM(11)=WSI(3)
      IF(SORT.EQ.1) CALL STORE(ITEM)
      IF(COPY.EQ.1)
     1WRITE(108,1)(X(L),L=1,40),ITEM(10),ITEM(10),ITEM(9),ITEM(11)
      IF(QUERY.NE.1) GOTO 5
      ITEM(10)=ITEM(10)*4
      ITEM(12)=13
      ASSIGN 416 TO IRETURN
      CALL RWRITC(1,ITEM,48,ITEM,31,100S)
 416  CONTINUE
      ASSIGN 417 TO IRETURN
      CALL RWRITC(1,ITEM,48,ITEM(9),4,101S)
 417  CONTINUE
      ASSIGN 5   TO IRETURN
      CALL RWRITC(1,ITEM,48,ITEM(10),8,102S)
 5    CONTINUE
      NBCARD=NBCARD+5
      DO 6 J=1,5
      READ(2,3,END=8000)(X(L),L=1,72)
 6    CONTINUE
      GOTO 2
 4    CONTINUE
      I=I+2
      CALL BLANC(I)
      CALL COMPACT(CMOVE,I)
      RETURN
 100  IF(ER.NE.22) WRITE(108,1)(X(L),L=1,40),ER; STOP 100
      ER=0; CALL READV(1,BUF1,L,ITEM,31,100S)
      BUF1(12)=BUF1(12)+3
      CALL RWRITE(1,BUF1,BUF1(12)*4,ITEM,31,100S)
      GOTO IRETURN
 101  IF(ER.NE.22) GOTO 100
      GOTO IRETURN
 102  IF(ER.NE.22) GOTO 100
      ER=0; CALL READV(1,BUF1,L,ITEM(10),8,100S)
      CALL FMVC(1,BUF1(BUF1(12)),0,ITEM(9),0,12)
      BUF1(12)=BUF1(12)+3
      CALL RWRITE(1,BUF1,BUF1(12)*4,ITEM(10),8,100S)
      GOTO IRETURN
 8000 RETURN
      END
C****************************************************
      SUBROUTINE AREATABLE
      IMPLICIT INTEGER (A-Z)
      COMMON /LISTING/QUERY,TOPOLOG,SORT,COPY,ER
      COMMON /BUFDUPL/BUF1(100)
      COMMON /INPUT/X(72)
      COMMON /CCB/CCB(13),SET(11),QSPAREA(2),HEADER(2),WSI(4),ITEM(12)
     1,AREAMSTR(10)
      COMMON /COMPACT1/CMOVE(20)
      COMMON /TABLE/NBGROUP,NBSET,NBCARD
      DATA MAS/4H-MAS/
      DATA TWO/4H2     /
      J=1 ; GOTO 1
C
      ENTRY AREAMASTER
      J=2
      GOTO 6
 1    CONTINUE
      NBCARD=NBCARD+1
      READ(2,3,END=8000)(X(L),L=1,72)
 3    FORMAT(72A1)
 6    CONTINUE
      I=1
      CALL BLANC(I)
      IF(J.EQ.1 .AND.X(I+1).NE.TWO) GOTO 4
      I=I+2
      CALL BLANC(I)
      CALL COMPACT(ITEM,I)
C     IF(J.EQ.2 .AND.ITEM(2).EQ.MAS) GOTO 4
      CALL FINDN(SET(2))
      CALL GET(WSI)
      ITEM(9)=WSI(1)
      ITEM(10)=WSI(2)
      IF(WSI(3).NE.5) ITEM(10)=WSI(2)/4
      ITEM(11)=WSI(3)
      IF(SORT.EQ.1) CALL STORE(ITEM)
      IF(COPY.EQ.1)
     1WRITE(108,15)(X(L),L=1,40),ITEM(10),ITEM(10),ITEM(9),ITEM(11)
  15  FORMAT(40A1,I6,1X,2Z10,I2)
      ITEM(10)=WSI(2)
      ITEM(12)=13
      CALL RWRITC(1,ITEM,48,ITEM,31,100S)
 486  ASSIGN 487 TO IRETURN
      CALL RWRITC(1,ITEM,48,ITEM(9),4,101S)
 487  ASSIGN 5 TO IRETURN
      CALL RWRITC(1,ITEM,48,ITEM(10),8,102S)
 5    CONTINUE
      IF(WSI(3).EQ.3) GOTO 40
      GOTO 1
 4    CONTINUE
      I=I+2
      CALL BLANC(I)
      CALL COMPACT(CMOVE,I)
      RETURN
 40   CONTINUE
      DO 41 L=1,5
      READ(2,3,END=8000)(X(L1),L1=1,72)
 41   CONTINUE
      GOTO 1
 8000 RETURN
 100  IF(ER.NE.22) WRITE(108,15)(X(L),L=1,40),ER; STOP 100
      ER=0; CALL READV(1,BUF1,L,ITEM,31,100S)
      CALL FMVC(BUF1(BUF1(12)),0,ITEM(9),0,12)
      BUF1(12)=BUF1(12)+3
      CALL RWRITE(1,BUF1,BUF1(12)*4,ITEM,31,100S)
      GOTO IRETURN
 101  IF(ER.NE.22) GOTO 100
      GOTO IRETURN
 102  IF(ER.NE.22) GOTO 100
      ER=0; CALL READV(1,BUF1,L,ITEM(10),8,100S)
      CALL FMVC(1,BUF1(BUF1(12)),0,ITEM(9),0,12)
      BUF1(12)=BUF1(12)+3
      CALL RWRITE(1,BUF1,BUF1(12)*4,ITEM(10),8,100S)
      GOTO IRETURN
      END
C********************************************************
      SUBROUTINE PRINT
      IMPLICIT INTEGER (A-Z)
      COMMON /LISTING/QUERY,TOPOLOG,SORT,COPY,ER
      COMMON /INPUT/X(72)
      COMMON /CCB/CCB(13),SET(11),QSPAREA(2),HEADER(2),
     1WSI(4),ITEM(12),AREAMASTER(10)
      CALL FINDG(HEADER)
  1   CONTINUE
      WRITE(108,2)
  2   FORMAT('***SORTED LISTING.',/,
     1'**********TYPES: 1  AREA, 2 GROUPS, 3 SETS, 5 ITEMS.',/)
 3    CONTINUE
      CALL FINDN(SET(7))
      IF(CCB(7).EQ.1) RETURN
      CALL GET(ITEM)
      WRITE(108,23)(ITEM(K),K=1,8),ITEM(10),ITEM(10),ITEM(9),ITEM(11)
      GOTO 3
      END
C******************************************************
      SUBROUTINE BLANC(I)
      IMPLICIT INTEGER (A-Z)
      COMMON /INPUT/X
      DIMENSION X(72)
       DATA BLAN/'    '/
      IF(I.LT.0) I=1
      IF(I.GT.72) RETURN
      DO 2 J=I,72
      IF(X(J).NE.BLAN) GOTO 3
   2  CONTINUE
   3   I=J
      RETURN
      END
C************************************************************
      SUBROUTINE COMPACT(CMOVE,I)
      IMPLICIT INTEGER (A-Z)
      COMMON /INPUT/X
      DIMENSION X(72),CMOVE(20)
      DATA BLAN/'    '/
      DO 2 J=1,20
  2   CMOVE(J)=BLAN
      CALL NBLAN(I,NB,M)
      M=I+NB-1
      N=-1
      DO 1 J=I,M
      N=N+1
      CALL FMVC(CMOVE,N,X(J),0,1)
   1  CONTINUE
      RETURN
      END
C***********************************************************
      SUBROUTINE NBLAN(I,NB,M)
      IMPLICIT INTEGER (A-Z)
      COMMON /INPUT/X
      DIMENSION X(72),BREAK(5)
      DATA BREAK/' ','.','(',')',' '/
      DO 1 J=I,72
      DO 5 M=1,5
  5   IF(X(J).EQ.BREAK(M)) GOTO 4
    1 CONTINUE
   4  NB=J-I
      RETURN
      END
      SUBROUTINE FINDNEXT
C
C**********************************************************
C                                                         *
C             WORKING STORAGE FOR IN CORE QS              *
C                                                         *
C**********************************************************
C      *        CCB CONTAINS 20 WORDS            *         *
C      * ERROR RETURN                            *         *
C      * 2 ADDR FOR SUBSCHEMA DEFN               *         *
C      * 3          AREA DEFINITION              *         *
C      * 4          ISAM DEFINITION              *         *
C      * 5          GROUP DEF                    *         *
C      * 6          ITEM  DEF                    *         *
C      * 7          CHECK DEF                    *         *
C      * 8          CONTROL DEF                  *         *
C      * 9          SET MEMBER                   *         *
C      *10          SET OWNER                    *         *
C      *11          ALIAS                        *         *
C      *12          CONTROL VIA MODIFY LK        *         *
C      *13          MEMBR VIA SET MEMBER LK      *         *
C      *14          GROUP-NO                     *         *
C      *******************************************         *
C      * 21-30       SUBSCHEMA                   *         *
C      * 31-50       AREA DEFINITION             *         *
C      * 51-60       ISEQ DEFINITION             *         *
C      * 61-70       GROUP DEFINITION            *         *
C      * 71-80       ITEM  DEFINITION            *         *
C      * 71-79       CHECK DEFINTION             *         *
C      * 91-100      CONTROL DEFINITION          *         *
C      *101-110      SET MEMBER                  *         *
C      *111-120      SET OWNER                   *         *
C      *121-130      ALIAS                       *         *
C      *******************************************         *
C***********************************************************
      IMPLICIT INTEGER (A-Z)
      COMMON /QSCCB/QSCCB(130)
      COMMON /SCHEMA/MX(4096)
      EQUIVALENCE(QSCCB(3),AREAPTR)
      EQUIVALENCE(QSCCB(4),ISAMPTR)
      EQUIVALENCE(QSCCB(5),GROUPTR)
      EQUIVALENCE(QSCCB(7),CHECKPTR)
      EQUIVALENCE(QSCCB(8),CONTROLPTR)
      EQUIVALENCE(QSCCB(9),SETPTR)
      EQUIVALENCE(QSCCB(10),OWNERPTR)
      EQUIVALENCE(QSCCB(11),ALIASPTR)
      EQUIVALENCE(QSCCB(12),MODIFYPTR)
      EQUIVALENCE(QSCCB(13),MEMBERPTR)
 20   CONTINUE
      ENTRY SUBSCHEMA
      SUBPTR=0
 7    CONTINUE
      SIZE=3
      PTRWSI=21
      CODE=7
      MASTER=0
      AREAPTR=0
      PTRCCB=1
      SUBPTR=0
      GOTO 100
C
      ENTRY AREALK
      SUBPTR=0
 1    CONTINUE
      SIZE=14
      PTRWSI=31
      CODE=1
      MASTER=7
      GROUPTR=0
      ISAMPTR=0
      PTRCCB=3
      IF(SUBPTR.NE.0) GOTO 100
      IF(AREAPTR.EQ.0) SUBPTR=IFIELD(QSCCB(23),15,17); GOTO 100
      SUBPTR=IFIELD(QSCCB(33),15,17)
      GOTO 100
C
      ENTRY GROUPLK
      SUBPTR=0
  2   CONTINUE
      SIZE=9
      PTRWSI=61
      CODE=2
      MASTER=1
      OWNERPTR=0
      MEMBERPTR=0
      ITEMPTR=0
      PTRCCB=5
      IF(SUBPTR.NE.0) GOTO 100
      IF(GROUPTR.EQ.0) SUBPTR=IFIELD(QSCCB(35),15,17); GOTO 100
      SUBPTR=IFIELD(QSCCB(65),15,17)
      GOTO 100
C
      ENTRY OWNERLK
      SUBPTR=0
 3    CONTINUE
      SIZE=4
      PTRWSI=111
      CODE=3
      MASTER=2
      SETPTR=0
      PTRCCB=10
      IF(SUBPTR.NE.0) GOTO 100
      IF(OWNERPTR.EQ.0) SUBPTR=IFIELD(QSCCB(62),15,17); GOTO 100
      SUBPTR=IFIELD(QSCCB(112),15,17)
      GOTO 100
C
      ENTRY ITEMLK
      SUBPTR=0
  5   CONTINUE
      SIZE=7
      PTRWSI=71
      CODE=5
      MASTER=2
      MODIFYPTR=0
      CHECKPTR=0
      PTRCCB=6
      IF(SUBPTR.NE.0) GOTO 100
      IF(ITEMPTR.EQ.0) SUBPTR=IFIELD(QSCCB(64),15,17); GOTO 100
      SUBPTR=IFIELD(QSCCB(74),15,17)
      GOTO 100
C
      ENTRY SETLK
      SUBPTR=0
 4    CONTINUE
      SIZE=6
      PTRWSI=101
      CODE=4
      MASTER=3
      ALIASPTR=0
      CONTROLPTR=0
      PTRCCB=9
      IF(SUBPTR.NE.0) GOTO 100
      IF(SETPTR.EQ.0)SUBPTR=IFIELD(QSCCB(114),15,17); GOTO 100
      SUBPTR=IFIELD(QSCCB(104),15,17)
      GOTO 100
C
      ENTRY FINDIRECT(I)
      J=IFIELD(MX(I+1),0,8)
      IF(J.EQ.0 .OR.J.EQ.8 .OR.J.GT.12) GOTO 500
      SUBPTR=I
      GOTO(1,2,3,14,5,6,7,8,9,10,11,12),J
C
      ENTRY MEMBERLK
      SUBPTR=0
      SIZE=6
      PTRWSI=101
      CODE=4
      MASTER=2
      ALIASPTR=0
      CONTROLPTR=0
      PTRCCB=13
      IF(MEMBERPTR.EQ.0) SUBPTR=IFIELD(QSCCB(63),15,17); GOTO 100
      SUBPTR=IFIELD(QSCCB(103),15,17)
      GOTO 100
 100  CONTINUE
      IF(IFIELD(MX(SUBPTR+1),0,8).EQ.CODE) GOTO 200
      IF(IFIELD(MX(SUBPTR+1),0,8).EQ.MASTER) GOTO 300
      QSCCB(1)=5
      RETURN
 300  QSCCB(1)=1
      QSCCB(14)=MASTER
      RETURN
 200  CONTINUE
      CALL FMVC(QSCCB(PTRWSI),0,MX(SUBPTR+1),0,SIZE*4)
      QSCCB(PTRCCB)=SUBPTR
      QSCCB(1)=0
      QSCCB(14)=CODE
      RETURN
 500  QSCCB(1)=6
      RETURN
 6    CONTINUE
 8    CONTINUE
 9    CONTINUE
 10   CONTINUE
 11   CONTINUE
 12   CONTINUE
      RETURN
 14   CONTINUE
      QSCCB(13)=0
      GOTO 4
      END
C     ROUTINE TO CONNECT QUAANSB CALLS TO CALLS TO
C      CALLS TO DISPIN AND QA
      SUBROUTINE QUAANSB (MES,NCH,ICODE,X,OFS,STATS,LENG)
      IMPLICIT INTEGER (A-Z)
      DIMENSION BUF(65)
      NB=132
      CALL QTRY (1S)
      CALL QA (MES,NCH,BUF,NB)
    3 IF (NB.LT.132) GO TO 2
      NB=128
      CALL QA (0,0,BUF(34),NB)
      NB=NB+132
      IF (NB.GT.256) GO TO 1
    2 CALL DISPIN (BUF,NB,ICODE,X,OFS,STATS,LENG)
      RETURN
    1 NB=132
      CALL QA ('  ERROR - TRY AGAIN: ',21,BUF,NB)
      GO TO 3
      END
