      IMPLICIT INTEGER(A-Z)
      COMMON /COMMAND/C(96),OTHERS(56)
      COMMON /IOTABLE/DEVICE,OUTMODE,EXECMODE,REFMODE,OCCURS,CHECKS,LOCK
     1,OUTPUT1(2)
      COMMON /LENGTH/LINPUT,MAXSEG,ACTSEG
      COMMON /INPUT/RESPON(36)
      COMMON /STRING/SEG(100)
      COMMON /BREAKS/BRKLIST(2)
      COMMON /SUBAREAS/SUBNBR,SUBAREAS(64),SUBKEY(2)
      COMMON /QSCCB/QSCCB(130)
      COMMON /CCB/CCB(1000)
      COMMON /AREAOPEN/AREAOPEN(2),OPENMODE(2),STATUS
      COMMON /KEYBUF/KEYERR,KEYBUF(35),KEYBUF1(35)
      COMMON /RETURNAD/RETURNAD,CMDNBR,ABORTERR,ERRSET
      COMMON /IOVALUE/EXECMOD,OUTMOD(5)
      COMMON /EXTRACT1/EXTRACT1(20)
      COMMON /TYPES/TYPES(8)
      EQUIVALENCE(CCB(1),REFCODE),(CCB(2),PAGENO(1))
      EQUIVALENCE(CCB(4),LINENO),(CCB(5),FRSTREF)
      EQUIVALENCE(CCB(6),LASTREF),(CCB(7),GRPNO)
      EQUIVALENCE(CCB(8),ERRNO),(CCB(9),ERRREF)
      EQUIVALENCE(CCB(11),PASSWORD(1)),(CCB(13),AREANO)
      EQUIVALENCE(SEG1,SEG(3)),(SEG2,SEG(4))
      EQUIVALENCE(KEYBUF(9),PTR),(KEYBUF(10),WSI),(KEYBUF(11),TYPE)
      INTEGER PAGENO(2),PASSWORD(2)
      EQUIVALENCE(OUTPUT1(1),INPUT),(OUTPUT1(2),OUTPUT)
      CALL MES(' IDDP D00 HERE',17)
 101  CONTINUE
      IF(AREAOPEN(1).NE.0 .OR.AREAOPEN(2).NE.0)
     1REFCODE=-1; CALL CLOSEDB
      AREAOPEN(1)=0; AREAOPEN(2)=0
      REFCODE=10
      STATUS=0
      CALL RESETERR
      CALL QSOPENF
C --------- OPENING THE QS FILE IN IN MODE.------------
      CALL OPENDCB(1,2,1,800S,KEYERR)
      CALL RINIT(1,270)
 102  CONTINUE
      CALL BREAK(103S)
      ASSIGN 501 TO ABORTDMS;  ASSIGN 502 TO ERRSET
        CALL DMSABORT(ABORTDMS); CALL SETERR(ERRSET)
 103  CALL QUAANSB(':',1,1,RESPON,0,103S,144)
      BRKLIST(1)=3
      ASSIGN 103 TO RETURNAD
      CALL SEGMENT
      IF(ACTSEG.EQ.0) GOTO 103
      DO 104 I=1,152,2
      CMDNBR=I/2+1
      IF(SEG1.NE.C(I)) GOTO 104
      IF(SEG2.NE.C(I+1)) GOTO 104
      IF(CMDNBR.GT.5.AND.CMDNBR.LT.40.AND.LOCK.EQ.1 )
     1CALL MES('***PLEASE STARTS IDDP WITH ANY EDMS OPEN COMMAND.',60);
     1GOTO 103
      GOTO
     1(1,2,3,4,5,6,7,8,9,10
     1,11,12,13,14,15,16,17,18,19,20
     1,21,22,23,24,25,26,27,28,29,30
     1,31,32,33,34,35,36,37,38,39,40
     1,41,42,43,44,45,46,47,48,49,50
     1,51,52,53,54,55,56,57,58,59,60
     1,61,62,63,64,65,66,67,68,69,70
     1,71,72,73,74,75,76
     1),CMDNBR
 104  CONTINUE
      CALL MES('   EH?',6)
      GOTO 103
C----------OPENRET,OPENUPD,CREATE,CLOSAREA-------------
 1    CONTINUE
 2    CONTINUE
 3    CONTINUE
 4    CONTINUE
 5    CONTINUE
 6    CONTINUE
      CALL IOPEN
      GOTO 103
C------------DELETE,DELETAUT,DELETSEL,REMOVE,REMOVSEL------C
 7    CONTINUE
 8    CONTINUE
 9    CONTINUE
 10   CONTINUE
 11   CONTINUE
      CALL UPDATE
      GOTO 103
C--------------FINDC,FINDG,FINDDUP,FIND,GET--------------C
 12   CONTINUE
 14   CONTINUE
 17   CONTINUE
 38   CONTINUE
 13   CONTINUE
      CALL IFINDG
 700  CONTINUE
      IF(EXECMODE.EQ.3) GOTO 103
      I=QSCCB(5)
      STATUS=1
      IF(OUTMODE.GT.2) CALL GROUPSYN(1)
      IF(CMDNBR.EQ.38) CALL GROUPSYN(0); I=QSCCB(5)
       WSI=4*IFIELD(QSCCB(61),15,17)
       IF(OUTMODE.EQ.2 .OR.OUTMODE.EQ.4 .OR.OUTMODE.EQ.5)
     1 CALL GET1(CCB,WSI,1)
      IF(OUTMODE.EQ.5) CALL IPRINT(I)
C-------------FINDN,SFINDN,SFINDS,SFINDSI,SFINDP,FINDN----C
  23   CONTINUE
  24   CONTINUE
  31   CONTINUE
  32   CONTINUE
  67   CONTINUE
  68   CONTINUE
       CALL SFINDN
       GOTO 103
  28   CONTINUE
  66   CONTINUE
       CALL SFINDSI
       GOTO 103
 27    CONTINUE
 65    CONTINUE
       CALL SFINDS
       GOTO 103
C--------------------STORE,LINK,DELINK,RELINK-------C
 18   CONTINUE
 22    CONTINUE
       CALL ISTORE
       GOTO 103
 19    CONTINUE
 20    CONTINUE
 21    CONTINUE
       CALL ILINK
       GOTO 103
C-------------------------FINDX---------------------C
 26   CONTINUE
 72   CONTINUE
      CALL IFINDX2
      GOTO 103
C-----------------------FINDM,HEAD,DMSCHKPT,CLOSEDB-----C
 15   CONTINUE
 16   CONTINUE
 34   CONTINUE
 33   CONTINUE
      CALL FINDHEAD
      GOTO 103
C
 37   CONTINUE
      IF(CHECKS.EQ.0) CALL CLOSEDB;CALL MES(' ALL AREAS CLOSED',20);
     1GOTO 103
      GOTO 999
 36   CONTINUE
      IF(CHECKS.EQ.0) GOTO 1000
 999  CONTINUE
      IF(AREAOPEN(1).EQ.0 .AND.AREAOPEN(2).EQ.0)
     1CALL MES('***AREAS NOT OPENED.',20); GOTO 103
      IF(CMDNBR.EQ.37) CALL CLOSEDB; CALL MES('  ALL AREAS CLOSED.',20);
     1AREAOPEN(1)=0; AREAOPEN(2)=0;  STATUS=0; GOTO 103
 1000 CONTINUE
      CALL DMSCHKPT
      GOTO 103
 40   CONTINUE
      CALL DMSTRACE
      GOTO 103
 35   CONTINUE
      CALL DMSRLSE
      GOTO 103
 41   CONTINUE
      CALL ENDTRACE
      GOTO 103
C----------------DMSSTATS,ENDSTATS,RPTSTATS---------------C
      CALL DMSSTATS
      GOTO 103
 43   CONTINUE
      CALL ENDSTATS
      GOTO 103
 44   CONTINUE
      CALL RPTSTATS
      GOTO 103
C------------------EXECMODE,OUTMODE,BUFFER--------------------
 49   CONTINUE
      CALL EXEC
      GOTO 103
 50   CONTINUE
      CALL OUT
      GOTO 103
 51   CONTINUE
      CALL BUFFER(CCB(1))
      GOTO 103
 52   CONTINUE
      CALL BUFFER(OCCURS)
      GOTO 103
C---------------------LISTONLP,LISTONME-----------------C
 53   CONTINUE
      CALL OPENLP
      DEVICE=4HLP
      GOTO 103
 54   CONTINUE
      CALL OPEN108
      DEVICE=4HME
      GOTO 103
 800  CALL MES('***UNABLE TO OPEN THE QUERY SCHEMA FILE.',40)
      STOP 800
C-------------------GROUPS,SETS,HELP--------------------C
  61   CONTINUE
       CALL GROUPS
       GOTO 103
 62   CONTINUE
      CALL SETS
      GOTO 103
C--------------------------SHOWGRP,SHOWSET,INPUTSET-------C
 55    CONTINUE
       CALL SHOWGRP
       GOTO 103
 63   CONTINUE
      CALL SHOWSET
      GOTO 103
 71   CONTINUE
      CALL INPUTSET
      GOTO 103
C------------------INPUT,OUTPUT,HELP,RESET,COMMANDS,END---
 56   CONTINUE
      L=1; GOTO 550
 57   CONTINUE
      L=2
 550  CALL OUTPUT10(L)
      GOTO 103
 59   CONTINUE
      CALL HELP
      GOTO 103
 64   CONTINUE
      CALL RESET
      GOTO 103
 70   CONTINUE
      CALL COMMANDS
      GOTO 103
 60   CONTINUE
      IF(AREAOPEN(1).NE.0 .OR.AREAOPEN(2).NE.0) CALL CLOSEDB
C--------------------NEWQS,REFCODE--------------------------
 69   CONTINUE
      CALL RESET
      GOTO 101
 58   CONTINUE
      IF(ACTSEG.EQ.1) CALL REFCODES(CCB(1)); GOTO 103
      CALL REFCOD(CCB(1))
      GOTO 103
C---------------NOCHECKS,CHECKS,OPTIONS------------C
 74   CONTINUE
      CHECKS=0
      GOTO 103
 75   CONTINUE
      CHECKS=1
      GOTO 103
 76   CONTINUE
      CALL OPTIONS
      GOTO 103
  25  CONTINUE
  29  CONTINUE
  30  CONTINUE
  39  CONTINUE
  45  CONTINUE
  46  CONTINUE
  47  CONTINUE
  48  CONTINUE
 73   CONTINUE
      CALL MES('***SORRY NOT YET IMPLEMENTED',32)
      GOTO 103
 501  CONTINUE
      WRITE(108,901)C(CMDNBR*2-1),C(CMDNBR*2),ERRNO, AREANO
 901  FORMAT('***ABORTING IN THE EXECUTION OF ',2A4,' WITH ERR ',I3,' IN
     1 AREA ',A2)
      CALL DMSRESET
      CALL RESET
      AREAOPEN(1)=0
      AREAOPEN(2)=0
      OPENMODE(1)=0; OPENMODE(2)=0; STATUS=0; REFCODE=-1
      CALL RESETERR
      GOTO 102
 502  CONTINUE
      WRITE(108,902)C(CMDNBR*2-1),C(CMDNBR*2),ERRNO, AREANO
 902  FORMAT('***DMS ERROR IN THE EXECUTION OF ',2A4,' WITH ERR ',I3,
     1  ' IN  AREA ',A2)
      GOTO 103
      END
      SUBROUTINE REFMODE
      IMPLICIT INTEGER(A-Z)
      COMMON /COMMAND/C(96),OTHERS(56)
      COMMON /IOTABLE/DEVICE,OUTMODE,EXECMODE,REFMODE,OCCURS,CHECKS,LAST
     1,OUTPUT1(2)
      COMMON /LENGTH/LINPUT,MAXSEG,ACTSEG
      COMMON /INPUT/RESPON(36)
      COMMON /STRING/SEG(100)
      COMMON /BREAKS/BRKLIST(2)
      COMMON /SUBAREAS/SUBNBR,SUBAREAS(64),SUBKEY(2)
      COMMON /CCB/CCB(1000)
      COMMON /AREAOPEN/AREAOPEN(2),OPENMODE(2),STATUS
      COMMON /KEYBUF/KEYERR,KEYBUF(35),KEYBUF1(35)
      COMMON /RETURNAD/RETURNAD,CMDNBR,ABORTERR,ERRSET
      COMMON /IOVALUE/EXECMOD,OUTMOD(5)
      COMMON /EXTRACT1/EXTRACT1(20)
      COMMON /TYPES/TYPES(8)
      EQUIVALENCE(CCB(1),REFCODE),(CCB(2),PAGENO(1))
      EQUIVALENCE(CCB(4),LINENO),(CCB(5),FRSTREF)
      EQUIVALENCE(CCB(6),LASTREF),(CCB(7),GRPNO)
      EQUIVALENCE(CCB(8),ERRNO),(CCB(9),ERRREF)
      EQUIVALENCE(CCB(10),PASSWORD(1)),(CCB(12),AREANO)
      EQUIVALENCE(SEG1,SEG(3)),(SEG2,SEG(4))
      EQUIVALENCE(KEYBUF(9),PTR),(KEYBUF(10),WSI),(KEYBUF(11),TYPE)
      INTEGER PAGENO(2),PASSWORD(2)
      EQUIVALENCE(OUTPUT1(1),INPUT),(OUTPUT1(2),OUTPUT)
      INTEGER SETTITLE(15)
      DATA SETTITLE/
     112HSET-OWNR=    ,
     112HSET-PRIR=    ,
     112HSET-CURR=    ,
     112HSET-NEXT=    ,
     112HSET-GRP.=    /
      DATA NORMAL,HEX/4HNORM,4HHEX  /
C-----------------EXECMODE---------------------------------C
 49   CONTINUE
      ENTRY EXEC
      IF(ACTSEG.GT.1) GOTO 100
 101  CONTINUE
      CALL QUAANSB('  DIRECT/EXECUTE/SETUP(D/E/S):',31,1,SEG(13),0
     1,RETURNAD,1)
 100  CONTINUE
      J1=0
      DO 102 J=1,17,8
      J1=J1+1
      IF(IFIELD(EXECMOD,J-1,8).EQ.IFIELD(SEG(13),0,8))  GOTO 103
 102  CONTINUE
      CALL MES('   EH?',6); GOTO 101
 103  EXECMODE=J1
      RETURN
C--------------------OUTMODE--------------------------------C
 50   CONTINUE
      ENTRY OUT
      IF(ACTSEG.GT.1) GOTO 200
 201  CONTINUE
      CALL QUAANSB('  OUTPUT MODE:(NONE,GET,REF,GREF,FULL):',42,1,
 200  CONTINUE
      DO 202 J=1,5
      IF(SEG(13).EQ.OUTMOD(J)) OUTMODE=J; RETURN
 202  CONTINUE
      CALL MES('   EH?',6); GOTO 201
C--------------------GROUPS--------------------------------C
 61   CONTINUE
      ENTRY SETS
      WRITE(108,601)
 601  FORMAT(/,' OWNERS       SETS          WSI ',/,
     1' ------------ ------------ -----')
      GOTO 300
      ENTRY GROUPS
      WRITE(108,2890)
 2890 FORMAT(/,' AREA NAMES    GPNO SIZE WSI  RANGE1-RANGE2 TYPE',
     1' INDX STAT',/,
     1         ' ---- -----    ---- ---- ---- ------------ -----',
     1' ---- ----')
 300  CONTINUE
      CALL FINDIRECT(0)
      IF(QSCCB(1).NE.0) CALL MES('***SUBSCHEMA NOT AVAILABLE.',27);
     1RETURN
 301  CALL AREALK
      IF(QSCCB(1).EQ.1) CALL MES(' ',1); RETURN
 302  CALL GROUPLK
      IF(QSCCB(1).EQ.1) GOTO 301
      IF(IFIELD(QSCCB(62),0,10).GT.999) GOTO 302
      CALL EXTRACT(2)
      IF(CMDNBR.EQ.62) GOTO 62
      WRITE(108,2891)(EXTRACT1(L),L=2,4),(EXTRACT1(L),L=11,18)
 2891 FORMAT(3X,I2,1X,2A4,1X,I4,1X,I4,1X,I4,1X,I6,1X,I6,1X,A4,1X,I3,I4)
      GOTO 302
C
 62   CONTINUE
      CALL OWNERLK
      IF(QSCCB(1).EQ.1) GOTO 302
      CALL READV(1,KEYBUF,L,UNMAP(QSCCB(10)),4,800S)
      WRITE(108,2892)(EXTRACT1(L),L=3,5),(KEYBUF(L),L=1,3),WSI/4
 2892 FORMAT(1X,3A4,1X,3A4,1X,I5)
      GOTO 62
 800  CALL MES('***SOMETHING IS WRONG WITH QUERY SCHEMA FILE.',50)
      GOTO RETURNAD
C
      ENTRY OUTPUT10(L55)
 400  CONTINUE
      IF(ACTSEG.GT.1 .AND.SEG(13).EQ.NORMAL) OUTPUT1(L55)=1; RETURN
      IF(ACTSEG.GT.1 .AND.SEG(13).EQ.HEX)  OUTPUT1(L55)=-1; RETURN
      ACTSEG=2
      GOTO 400
C
      ENTRY RESET
      EXECMODE=1
      OUTMODE=5
      INPUT=1
      OUTPUT=1
      OCCURS=1
      CALL OPEN108
      CHECKS=1
      DEVICE=4HME
      RETURN
C
      ENTRY HELP
      CALL MES(' FOR A LIST OF COMMANDS TYPE : COMMANDS ',40)
      CALL MES(' FOR A LIST OF GROUP NAMES TYPE: GROUPS ',40)
      CALL MES(' FOR A LIST OF   SET NAMES TYPE:   SETS ',40)
      RETURN
      ENTRY BUFFER(L55)
      CALL QTRY(401S)
      IF(ACTSEG.GT.1)
     1CALL DISPIN(SEG(13),SEG(11),4,L55,0,0,12);    CALL QTRY(0); RETURN
 401  CONTINUE
      CALL QTRY(0)
      CALL QUAANSB('  VALUE:',8,4,L55,0,RETURNAD,12)
      RETURN
C
      ENTRY COMMANDS
      CALL MES(' ',1); CALL MES('  DBM COMMANDS:',16)
      WRITE(108,420)(C(L),L=1,10)
      WRITE(108,420)C(73),C(74),(C(L),L=11,18)
      WRITE(108,420)(C(L),L=19,28)
      WRITE(108,420)(C(L),L=29,38)
      WRITE(108,420)(C(L),L=39,48)
      WRITE(108,420)(C(L),L=51,56),(C(L),L=61,64)
      WRITE(108,420)(C(L),L=65,72),C(75),C(76)
      WRITE(108,420)(C(L),L=79,88)
      CALL MES(' ',1); CALL MES('  I/O COMMANDS:',16)
      WRITE(108,420)(OTHERS(L),L=1,10)
      WRITE(108,420)(OTHERS(11),OTHERS(12)),(OTHERS(L),L=15,18)
     1,OTHERS(31),OTHERS(32),OTHERS(41),OTHERS(42)
      WRITE(108,420)(OTHERS(L),L=51,54),OTHERS(55),OTHERS(56)
      CALL MES(' ',1); CALL MES('  GENERAL COMMANDS:',30)
      WRITE(108,420)OTHERS(13),OTHERS(14),(OTHERS(L),L=19,26)
      WRITE(108,420)(OTHERS(L),L=27,30),OTHERS(43),OTHERS(44)
     1,OTHERS(45),OTHERS(46)
      CALL MES(' ',1); CALL MES('  DUMP COMMANDS:',20)
      CALL MES(' ',1)
      RETURN
 420  FORMAT(1X,5(2A4,2X))
C
      ENTRY SHOWSET
      CALL ASKSET
      CALL FINDIRECT(0)
 1220 CALL AREALK
      IF(QSCCB(1).EQ.1) CALL MES('***SUBSCHEMA NOT PRESENT',20);RETURN
      IF(IFIELD(QSCCB(33),0,8).NE.EXTRACT1(2)) GOTO 1220
      LINE=IFIELD(QSCCB(34),9,4)
      DO 1222 J=1,5
      WRITE(108,1221)(SETTITLE((J-1)*3+L),L=1,3),
     1IFIELD(CCB(WSI/4+1),0,8),IFIELD(CCB(WSI/4+1),8,24-LINE),
     1IFIELD(CCB(WSI/4+1),32-LINE,LINE)
      WSI=WSI+4
 1222 CONTINUE
      RETURN
 1221 FORMAT(1X,3A4,2X,I2,1X,I5,1X,I3)
C
      ENTRY INPUTSET
      CALL ASKSET
      DO 1300 J=1,5
      CALL MESS(SETTITLE(J*3-2),12)
      CALL REFCODES(CCB(WSI/4+1))
      WSI=WSI+4
 1300 CONTINUE
      RETURN
C
      ENTRY OPTIONS
      I2=4HME
      IF(EXECMODE.EQ.2) I2=4HD
      IF(EXECMODE.EQ.3) I2=4HS
      I3=4HYES
      IF(CHECKS.EQ.0) I3=4HNO
      I4=NORMAL
      IF(INPUT.EQ.-1)  I4=HEX
      I5=NORMAL
      IF(OUTPUT.EQ.-1) I5=HEX
      WRITE(108,1320)
      WRITE(108,1321)DEVICE,I2,OUTMOD(OUTMODE),I4,I5,I3,OCCURS
 1321 FORMAT(1X,A4,3X,A4,5X,A4,5X,A4,2X,A4,3X,A4,2X,I6)
 1320 FORMAT(' DEVICE EXECMODE OUTMODE  INPUT OUTPUT CHECKS OCCURS',/,
     1       ' ------ -------- -------  ----- ------ ------ ------')
      RETURN
      END
C**********************************************************
      SUBROUTINE EXTRACT(I)
      IMPLICIT INTEGER(A-Z)
      COMMON /COMMAND/C(96),OTHERS(56)
      COMMON /IOTABLE/DEVICE,OUTMODE,EXECMODE,REFMODE,OCCURS,FIRST,LAST
     1,INPUT
      COMMON /INPUT/RESPON(36)
      COMMON /STRING/SEG(100)
      COMMON /BREAKS/BRKLIST(2)
      COMMON /SUBAREAS/SUBNBR,SUBAREAS(64),SUBKEY(2)
      COMMON /QSCCB/QSCCB(130)
      COMMON /CCB/CCB(1000)
      COMMON /AREAOPEN/AREAOPEN(2),OPENMODE(2),STATUS
      COMMON /KEYBUF/KEYERR,KEYBUF(35),KEYBUF1(35)
      COMMON /RETURNAD/RETURNAD,CMDNBR
      COMMON /IOVALUE/EXECMOD,OUTMOD(5)
      COMMON /EXTRACT1/EXTRACT1(20)
      EQUIVALENCE(CCB(1),REFCODE),(CCB(2),PAGENO(1))
      EQUIVALENCE(CCB(4),LINENO),(CCB(5),FRSTREF)
      EQUIVALENCE(CCB(6),GRPNO),(CCB(7),ERRCODE)
      EQUIVALENCE(CCB(8),ERRNO),(CCB(9),ERRREF)
      EQUIVALENCE(CCB(10),PASSWORD(1)),(CCB(12),AREANO)
      EQUIVALENCE(SEG1,SEG(3)),(SEG2,SEG(4))
      EQUIVALENCE(KEYBUF(9),PTR),(KEYBUF(10),WSI),(KEYBUF(11),TYPE)
      INTEGER PAGENO(2),PASSWORD(2)
      INTEGER TYPE1(4)
      DATA TYPE1/16HCALCDIREISAMVIA /
      EQUIVALENCE(EXTRACT1(11),GROUPNO)
      EQUIVALENCE(EXTRACT1(12),SIZE)
      EQUIVALENCE(EXTRACT1(13),WSI2)
      EQUIVALENCE(EXTRACT1(14),RANGE1)
      EQUIVALENCE(EXTRACT1(15),RANGE2)
      EQUIVALENCE(EXTRACT1(16),TYPE2)
      EQUIVALENCE(EXTRACT1(17),INDEX)
      EQUIVALENCE(EXTRACT1(18),STATS)
      GOTO(1,2,3,4,5,6,7,8,9,10,11),I
 2    CONTINUE
      EXTRACT1(1)=0
      EXTRACT1(2)=SCHMABIT(IFIELD(QSCCB(66),15,17)+2,0,8)
      CALL READV(1,EXTRACT1(3),L,UNMAP(QSCCB(5)),4,800S)
      GROUPNO=IFIELD(QSCCB(62),0,10)
      WSI2=IFIELD(QSCCB(61),15,17)
      SIZE=IFIELD(QSCCB(66),0,10)+1
      IF(IFIELD(QSCCB(61),12,1).EQ.0) RANGE1=0;RANGE2=0; GOTO 20
      RANGE1=IFIELD(QSCCB(67),13,19)
      RANGE2=IFIELD(QSCCB(68),13,19)
 20   CONTINUE
      J1=IFIELD(QSCCB(61),8,3)
      IF(J1.EQ.0.AND.IFIELD(QSCCB(61),14,1).NE.1)TYPE2=TYPE1(4); GOTO 21
      IF(J1.EQ.0.AND.IFIELD(QSCCB(61),14,1).EQ.1)TYPE2=TYPE1(3); GOTO 21
      TYPE2=TYPE1(IFIELD(QSCCB(61),8,3))
 21   CONTINUE
      STATS=IFIELD(QSCCB(62),14,1)
      INDEX=IFIELD(QSCCB(61),13,1)
      RETURN
 800  CALL MES('***SOMETHING IS WRONG IN READING THE SUBSCHEMA.',60)
      GOTO RETURNAD
 4     CONTINUE
 6     CONTINUE
 7     CONTINUE
 8     CONTINUE
 9     CONTINUE
 10    CONTINUE
 11    CONTINUE
 1     CONTINUE
       RETURN
 5     CONTINUE
       CALL READV(1,EXTRACT1(3),L,UNMAP(QSCCB(6)),4,800S)
       EXTRACT1(11)=IFIELD(QSCCB(71),9,3)
       EXTRACT1(12)=IFIELD(QSCCB(71),13,19)
       EXTRACT1(13)=IFIELD(QSCCB(72),0,11)
       EXTRACT1(14)=IFIELD(QSCCB(71),8,1)
       EXTRACT1(15)=IFIELD(QSCCB(73),13,1)
       EXTRACT1(16)=IFIELD(QSCCB(74),14,1)
       EXTRACT1(17)=SCHMABIT(IFIELD(QSCCB(75),15,17)+1,0,10)
       EXTRACT1(18)=SCHMABIT(IFIELD(QSCCB(74),15,17),13,19)
       RETURN
C
C SET INFORMATION:AREA,NAME,WSI,MASTERSYN
 3    CONTINUE
       CALL READV(1,EXTRACT1(3),L,UNMAP(QSCCB(10)),4,800S)
       EXTRACT1(2)=SCHMABIT(SCHMABIT(IFIELD(QSCCB(113),15,17)+5,15,17)+2
     1,0,8)
      EXTRACT1(11)=IFIELD(QSCCB(111),15,17)
      EXTRACT1(12)=IFIELD(QSCCB(112),0,10)
      RETURN
      END
C***********************SUBROUTINE REFCODES*******************C
      SUBROUTINE REFCODES(REFCODE1)
      IMPLICIT INTEGER(A-Z)
      COMMON /COMMAND/C(96),OTHERS(56)
      COMMON /IOTABLE/DEVICE,OUTMODE,EXECMODE,REFMODE,OCCURS,FIRST,LAST
     1,INPUT
      COMMON /LENGTH/LINPUT,MAXSEG,ACTSEG
      COMMON /STRING/SEG(100)
      COMMON /BREAKS/BRKLIST(2)
      COMMON /SUBAREAS/SUBNBR,SUBAREAS(64),SUBKEY(2)
      COMMON /QSCCB/QSCCB(130)
      COMMON /CCB/CCB(1000)
      COMMON /AREAOPEN/AREAOPEN(2),OPENMODE(2),STATUS
      COMMON /KEYBUF/KEYERR,KEYBUF(35),KEYBUF1(35)
      COMMON /RETURNAD/RETURNAD,CMDNBR,ABORTERR,ERRSET
      COMMON /IOVALUE/EXECMOD,OUTMOD(5)
      COMMON /EXTRACT1/EXTRACT1(20)
      COMMON /TYPES/TYPES(8)
      EQUIVALENCE(CCB(1),REFCODE),(CCB(2),PAGENO(1))
      EQUIVALENCE(CCB(4),LINENO),(CCB(5),FRSTREF)
      EQUIVALENCE(CCB(6),GRPNO),(CCB(7),ERRCODE)
      EQUIVALENCE(CCB(8),ERRNO),(CCB(9),ERRREF)
      EQUIVALENCE(CCB(10),PASSWORD(1)),(CCB(12),AREANO)
      EQUIVALENCE(SEG1,SEG(3)),(SEG2,SEG(4))
      EQUIVALENCE(KEYBUF(9),PTR),(KEYBUF(10),WSI),(KEYBUF(11),TYPE)
      INTEGER PAGENO(2),PASSWORD(2)
      INTEGER AREA1(3)
      EQUIVALENCE(AREA1(1),SEG(90))
 1    CONTINUE
      CALL QUAANSB(' REFCODE:',10,1,RESPON,0,200S,144)
 21   CONTINUE
      BRKLIST(1)=4
      CALL SEGMENT
      CALL QTRY(10S)
      IF(ACTSEG.LT.2 .OR.ACTSEG.GT.3)
     1CALL MES('***TOO FEW OR TOO MANY FIELDS.RETRY.',40) ;GOTO  1
      L1=ACTSEG*10
      M=1
      DO 3 J=3,L1,10
      CALL DISPIN(SEG(J),SEG(J-2),4,AREA1(M),0,0,12)
      M=M+1
 3    CONTINUE
      IF(AREA1(1).GT.64 .OR.AREA1(1).LT.1)
     1CALL MES('***INVALID AREA NUMBER ',28); GOTO 1
      IF(ACTSEG.EQ.3 .AND.
     1(AREA1(2).LT.0   .OR.AREA1(3).GT.256 .OR.AREA1(3).LT.0))
     1CALL MES('***INVALID PAGE OR LINE NUMBER.',30) ; GOTO 1
      CALL FINDIRECT(0)
  5   CONTINUE
      CALL AREALK
      IF(QSCCB(1).EQ.1) CALL MES('***NO SUCH AREA.',16); GOTO 1
      IF(IFIELD(QSCCB(33),0,8).NE.AREA1(1)) GOTO 5
      IF(ACTSEG.EQ.2) CALL FMVC(REFCODE1,0,AREA1(1),3,1);
     1CALL FMVC(REFCODE1,1,AREA1(2),1,3); GOTO 200
      L=IFIELD(QSCCB(34),9,4)
      L1=0
      CALL FMVC(L1,0,AREA1(1),3,1)
      REFCODE1=L1+AREA1(2)*(2**L)+AREA1(3)
 200  RETURN
 10   CONTINUE
      CALL QTRY(0)
      CALL MES('***INVALID REFCODE.',20)
      GOTO 1
C
      ENTRY REFCOD(REFCODE1)
      DO 25 J=1,36
25    RESPON(J)=4H
      DO 20 J=13,34,10
      CALL FMVC(RESPON(J-12),0,SEG(J),0,32)
  20  CONTINUE
      GOTO 21
      END
C----------------------FUNCTION CHECK OPEN--------------C
      INTEGER FUNCTION OPENCHECK(I)
      IMPLICIT INTEGER (A-Z)
      COMMON /AREAOPEN/AREAOPEN(2)
      J1=1
      L=I
      IF(I.GT.31) L=I-32; J1=2
      OPENCHECK=IFIELD(AREAOPEN(J1),L,1)
      RETURN
      END
      BLOCK DATA
      IMPLICIT INTEGER(A-Z)
      COMMON /COMMAND/C(96),OTHERS(56)
      COMMON /IOTABLE/DEVICE,OUTMODE,EXECMODE,REFMODE,OCCURS,CHECKS,LOCK
     1,OUTPUT1(2)
      COMMON /LENGTH/LINPUT,MAXSEG,ACTSEG
      COMMON /INPUT/RESPON(36)
      COMMON /STRING/SEG(100)
      COMMON /BREAKS/BRKLIST(2)
      COMMON /SUBAREAS/SUBNBR,SUBAREAS(64),SUBKEY(2)
      COMMON /QSCCB/QSCCB(130)
      COMMON /CCB/CCB(3000)
      COMMON /AREAOPEN/AREAOPEN(2),OPENMODE(2),STATUS
      COMMON /KEYBUF/KEYERR,KEYBUF(35),KEYBUF1(35)
      COMMON /RETURNAD/RETURNAD,CMDNBR,ABORTERR,ERRSET,ACTUALGR,MESSAGE
      COMMON /IOVALUE/EXECMOD,OUTMOD(5)
      COMMON /EXTRACT1/EXTRACT1(20)
      COMMON /TYPES/TYPES(8)
      COMMON /BUFFERS/BUFFERS(75)
      COMMON /BCOUNT/BCOUNT
      EQUIVALENCE(CCB(1),REFCODE),(CCB(2),PAGENO(1))
      EQUIVALENCE(CCB(4),LINENO),(CCB(5),FRSTREF)
      EQUIVALENCE(CCB(6),LASTREF),(CCB(7),GRPNO)
      EQUIVALENCE(CCB(8),ERRNO),(CCB(9),ERRREF)
      EQUIVALENCE(CCB(10),PASSWORD(1)),(CCB(12),AREANO)
      EQUIVALENCE(SEG1,SEG(3)),(SEG2,SEG(4))
      EQUIVALENCE(KEYBUF(9),PTR),(KEYBUF(10),WSI),(KEYBUF(11),TYPE)
      INTEGER PAGENO(2),PASSWORD(2)
      EQUIVALENCE(OUTPUT1(1),INPUT),(OUTPUT1(2),OUTPUT)
      DATA C/
     18HOPENUPD ,8HOPRETSHD,8HOPENRET ,8HOPUPDSHD,8HCREATE  ,
     18HCLOSAREA,8HDELETE  ,8HDELETAUT,8HDELETSEL,8HREMOVE  ,
     18HREMOVSEL,8HFINDC   ,8HFINDG   ,8HFINDDUP ,8HFINDFRST,
     18HFINDLAST,8HGET     ,8HMODIFY  ,8HLINK    ,8HDELINK  ,
     18HRELINK  ,8HSTORE   ,8HFINDN   ,8HFINDP   ,8HFINDSEQ ,
     18HFINDX   ,8HFINDS   ,8HFINDSI  ,8H        ,8H        ,
     18HFINDN   ,8HFINDP   ,8HFINDM   ,8HHEAD    ,8HDMSRLSE ,
     18HDMSCHKPT,8HCLOSEDB ,8HFINDD   ,8HDMSRETRN,8HDMSTRACE,
     18HENDTRACE,8HDMSSTATS,8HENDSTATS,8HRPTSTATS,8HDMSABORT,
     18HSETERR  ,8HRESETERR,8HDMSLOCK /
      DATA LINPUT,MAXSEG,ACTSEG/144,10,0/
      DATA BRKLIST/3,4H, /-/
      DATA AREAOPEN,OPENMODE,STATUS/5*0/
      DATA SUBKEY/8HSUB#AREA/
      DATA EXECMODE,OUTMODE,OCCURS/1,5,0/
      DATA EXECMOD,OUTMOD/4HEDS ,20HNONEGET REF GREFFULL/
      DATA TYPES/32H+NUMAN  NUM A   BIN FLTSFLTLPACD/
      DATA INPUT,OUTPUT/1,1/
      DATA CHECKS/1/
      DATA DEVICE/4HME    /
      DATA QSCCB/130*0/
      DATA LOCK/1/
      DATA KEYBUF1/35*0/
      DATA BCOUNT/75/
      DATA OTHERS/
     140HEXECMODEOUTMODE BUFFER  OCCURS  LISTONLP ,
     140HLISTONMESHOWGRP INPUT   OUTPUT  REFCODE  ,
     140HHELP    END     GROUPS  SETS    SHOWSET  ,
     140HRESET   SFINDS  SFINDSI SFINDN  SFINDP   ,
     140HNEWQS   COMMANDSINPUTSETSFINDX           ,
     124HNOCHECKSCHECKS  OPTIONS    /
C IOTABLE
C--------
C DEVICE=1 FOR LP, 0 FOR TTY
C REFMODE=0 DECIMAL, 1 HEX
C INPUT  =0 NORMAL,  1 HEX
C OUTMODE=1 NONE
C         2 GET
C         3 REFC
C         4 GREF
C         5 FULL
C EXECMODE= 1 EXECUTE
C           2 DIRECT
C           3 SETUP
C OCCURS =1 OR NBR>1
C
C CHECKS=1 FOR CHECKING ; FOR NO CHECKING
C DEVICE=1 FOR ME; 2 FOR LP
C
      END
      SUBROUTINE SFINDSI
      IMPLICIT INTEGER(A-Z)
      COMMON /COMMAND/C(96),OTHERS(56)
      COMMON /IOTABLE/DEVICE,OUTMODE,EXECMODE,REFMODE,OCCURS,CHECKS,LAST
     1,OUTPUT1(2)
      COMMON /LENGTH/LINPUT,MAXSEG,ACTSEG
      COMMON /INPUT/RESPON(36)
      COMMON /STRING/SEG(100)
      COMMON /BREAKS/BRKLIST(2)
      COMMON /SUBAREAS/SUBNBR,SUBAREAS(64),SUBKEY(2)
      COMMON /QSCCB/QSCCB(130)
      COMMON /CCB/CCB(1000)
      COMMON /AREAOPEN/AREAOPEN(2),OPENMODE(2),STATUS
      COMMON /KEYBUF/KEYERR,KEYBUF(35),KEYBUF1(35)
      COMMON /RETURNAD/RETURNAD,CMDNBR,ABORTERR,ERRSET
      COMMON /IOVALUE/EXECMOD,OUTMOD(5)
      COMMON /EXTRACT1/EXTRACT1(20)
      COMMON /TYPES/TYPES(8)
      EQUIVALENCE(CCB(1),REFCODE),(CCB(2),PAGENO(1))
      EQUIVALENCE(CCB(4),LINENO),(CCB(5),FRSTREF)
      EQUIVALENCE(CCB(6),LASTREF),(CCB(7),GRPNO)
      EQUIVALENCE(CCB(8),ERRNO),(CCB(9),ERRREF)
      EQUIVALENCE(CCB(10),PASSWORD(1)),(CCB(12),AREANO)
      EQUIVALENCE(SEG1,SEG(3)),(SEG2,SEG(4))
      EQUIVALENCE(KEYBUF(9),PTR),(KEYBUF(10),WSI),(KEYBUF(11),TYPE)
      INTEGER PAGENO(2),PASSWORD(2)
C--------------ENTRY SFINDSI,FINDSI--------------------C
      IF(EXECMODE.EQ.2.AND.CMDNBR.LT.61) GOTO 284
      SYN1=2000
      CALL FIRSTREF
      CALL QUAANSB('           COUNT:',20,4,CCB(6),0,RETURNAD,5)
      IF(CMDNBR.EQ.66) CALL SYNSELECT; CALL NEXTFIND
 284  CONTINUE
      IF(EXECMODE.EQ.3) GOTO RETURNAD
      IF(CHECKS.EQ.0) GOTO 280
      I=OPENCHECK(IFIELD(CCB(5),0,8))
 281  CONTINUE
      IF(I.NE.1) CALL MES('***REFCODE DO NOT BELONG TO AN OPENED AREA.'
     1,50); GOTO RETURNAD
 280  CONTINUE
      CALL FINDSI(RETURNAD)
      IF(CMDNBR.LT.61) GOTO 282
      IF(CMDNBR.EQ.66 .AND.SYN1.EQ.2000) GOTO 282
      IF(SYN1.NE.CCB(7)) GOTO 280
 282  CONTINUE
      CALL GETPRINT
      IF(CMDNBR.NE.66) RETURN
      IF(NEXT.NE.0)     CALL CONTINUS
      GOTO 280
C---------------ENTRY SFINDS,FINDS--------------------C
      ENTRY SFINDS
      IF(EXECMODE.EQ.2 .AND.CMDNBR.LT.61) GOTO 274
      SYN1=2000
      CALL FIRSTREF
      CALL LASTREF1
      IF(CMDNBR.EQ.65) CALL SYNSELECT; CALL NEXTFIND
 274  CONTINUE
      IF(EXECMODE.EQ.3) RETURN
      IF(CHECKS.EQ.0) GOTO 270
      I=OPENCHECK(IFIELD(CCB(5),0,8))
      IF(I.EQ.0) GOTO 281
 270  CONTINUE
      CALL FINDS(RETURNAD)
      IF(CMDNBR.LT.61) GOTO 271
      IF(CMDNBR.EQ.65 .AND.SYN1.EQ.2000) GOTO 271
      IF(SYN1.NE.CCB(7)) GOTO 270
 271  CONTINUE
      CALL GETPRINT
      IF(CMDNBR.NE.65) RETURN
      IF(NEXT.NE.0) CALL CONTINUS
      GOTO 270
C-----------ENTRY SFINDN,FINDN,SFINDP,FINDP-------------C
      ENTRY SFINDN
      IF(ACTSEG.GT.1) GOTO 240
 231  CONTINUE
      CALL QUAANSB(
     1'  ENTER GROUP OR SET NAME:',28,1,SEG(13),0,RETURNAD,32)
 240  CONTINUE
      CALL READV(1,KEYBUF,L,SEG(13),31,800S)
      IF(TYPE.LT.2 .OR.TYPE.GT.3) GOTO 800
 241  CONTINUE
      CALL FINDIRECT(PTR)
      CALL EXTRACT(TYPE)
      ISAM=4HISAM
      IF(TYPE.EQ.3) GOTO 232
      IF(CHECKS.EQ.0) GOTO 232
      IF(EXTRACT1(16).NE.ISAM)
     1CALL MES('***THIS IS NOT AN ISAM GROUP.',32); GOTO RETURNAD
 232  CONTINUE
      IF(TYPE.NE.2 .AND.CMDNBR.GT.48) CALL SYNSELECT; CALL NEXTFIND
      IF(EXECMODE.EQ.3) RETURN
      IF(CHECKS.EQ.0) GOTO 999
      IF(OPENCHECK(EXTRACT1(2)).NE.1)
     1CALL MES('***GROUP OR SET BELONG TO AN UNOPENED AREA',50)
     1;GOTO RETURNAD
      IF(CMDNBR.EQ.15 .OR.CMDNBR.EQ.16) GOTO 230
      IF(TYPE.EQ.2) CALL CHECKPAGESET
      IF(TYPE.EQ.3) CALL CHECKSET
 999  CONTINUE
      IF(TYPE.EQ.3 .AND.CMDNBR.EQ.23) CMDNBR=31
      IF(TYPE.EQ.3 .AND.CMDNBR.EQ.24) CMDNBR=32
      IF(TYPE.EQ.2 .AND.CMDNBR.EQ.67) CMDNBR=72
      IF(TYPE.EQ.2 .AND.CMDNBR.EQ.68) CMDNBR=73
      IF(TYPE.EQ.2) WSI1=IFIELD(QSCCB(61),15,17)*4; MASTER=2000;
     1SYN1=2000
      IF(TYPE.EQ.3) WSI1=IFIELD(QSCCB(111),15,17)*4; MASTER=EXTRACT1(12)
      IF(CMDNBR.GT.61.AND.TYPE.EQ.2) CALL NEXTFIND
230   CONTINUE
C     WSI=WSI1
      IF(CMDNBR.EQ.23 .OR.CMDNBR.EQ.72)
     1CALL FINDNX(CCB,WSI,RETURNAD)
      IF(CMDNBR.EQ.24 .OR.CMDNBR.EQ.73)
     1CALL FINDPX(CCB,WSI,RETURNAD)
      IF(CMDNBR.EQ.31 .OR.CMDNBR.EQ.67) CALL FINDN1(CCB,WSI,1)
      IF(CMDNBR.EQ.32 .OR.CMDNBR.EQ.68) CALL FINDP1(CCB,WSI,1)
      IF(CMDNBR.EQ.33) CALL FINDM1(CCB,WSI,1)
      IF(CMDNBR.EQ.34) CALL HEAD1(CCB,WSI,1)
      IF(CMDNBR.EQ.15) CALL FINDFRS1(CCB,WSI,1)
      IF(CMDNBR.LT.49) GOTO 235
      IF(SYN1.EQ.2000) GOTO 235
      IF(CCB(7).NE.SYN1) GOTO 236
 235  CONTINUE
      CALL GETPRINT
      IF(CMDNBR.LT.49) RETURN
      IF(CCB(7).EQ.EXTRACT1(12)) RETURN
      IF(NEXT.NE.0)     CALL CONTINUS
 236  CONTINUE
      IF(CCB(7).EQ.MASTER) RETURN
      GOTO 230
C
 800  CONTINUE
      CALL MES('***THIS IS NOT A GROUP OR A SET NAME.',40)
      GOTO 231
C
      ENTRY FINDHEAD
      IF(ACTSEG.GT.1) GOTO 820
 810  CONTINUE
       IF(CMDNBR.LT.17) CALL MESS('  GROUP NAME. RETRY',19)
       IF(CMDNBR.GT.17) CALL MESS('    SET NAME. RETRY',19)
      CALL QUAANSB(':',1,1,SEG(13),0,RETURNAD,32)
 820  CONTINUE
      CALL READV(1,KEYBUF,L,SEG(13),31,801S)
      IF(TYPE.EQ.3 .AND.CMDNBR.GT.17) GOTO 241
      IF(TYPE.EQ.2 .AND.CMDNBR.LT.17) GOTO 241
 801  CONTINUE
      CALL MESS('***THIS IS NOT A VALID ',30)
      GOTO 810
C
      SUBROUTINE GETPRINT
      WSI1=WSI
      STATUS=1
      IF(OUTMODE.EQ.1) RETURN
      IF(OUTMODE.GT.2) CALL GROUPSYN(1)
      CALL GROUPSYN(0)
      WSI=4*IFIELD(QSCCB(61),15,17)
      IF(OUTMODE.EQ.2 .OR.OUTMODE.EQ.4 .OR.OUTMODE.EQ.5)
     1CALL GET1(CCB,WSI,1)
      IF(OUTMODE.EQ.5) CALL IPRINT(QSCCB(5))
      WSI=WSI1
      RETURN
C
C
      SUBROUTINE FIRSTREF
 1    CONTINUE
      CALL MESS('  FIRST',9)
      CALL REFCODES(CCB(5))
      EXTRACT1(2)=IFIELD(CCB(5),0,8)
      RETURN
C
      SUBROUTINE LASTREF1
      CALL MESS('    LAST',9)
      CALL REFCODES(CCB(6))
      RETURN
C
      SUBROUTINE NEXTFIND
      NEXT=0
      CALL QUAANSB('   CONTINUOUS OR WITH PAUSES(0/1):',36,4,NEXT,0,0,1)
      RETURN
C
      SUBROUTINE CONTINUS
      PAUSE=4HNEXT
      YES=4HYES
      PAUSE2=4HYES
      CALL QUAANSB('   NEXT?',8,1,PAUSE2,0,10S,4)
      IF(PAUSE2.EQ.PAUSE .OR.PAUSE2.EQ.YES) PAUSE2=YES; RETURN
      GOTO RETURNAD
 10   RETURN
C
      SUBROUTINE SYNSELECT
      SYN1=2000
      CALL QUAANSB('   SYN SELECTED:',20,4,SYN1,0,11S,4)
  11  RETURN
C
      SUBROUTINE CHECKPAGESET
      CALL FINDIRECT(0)
 9001 CALL AREALK
      IF(QSCCB(1).EQ.1) RETURN
      IF(IFIELD(QSCCB(33),0,8).NE.EXTRACT1(2)) GOTO 9001
 9002 CALL GROUPLK
      IF(QSCCB(1).EQ.1) RETURN
      IF(IFIELD(QSCCB(62),0,10).NE.1001) GOTO 9002
      CALL OWNERLK
      CALL CHECKSET
      RETURN
C
      SUBROUTINE CHECKSET
      IF(CCB(IFIELD(QSCCB(111),15,17)+3).NE.0)   RETURN
      CALL MES('***SET-TABLE HAS NO CURRENT MEMBER.',40)
      GOTO RETURNAD
      END
       SUBROUTINE IFINDG
      IMPLICIT INTEGER(A-Z)
      COMMON /COMMAND/C(96),OTHERS(56)
      COMMON /IOTABLE/DEVICE,OUTMODE,EXECMODE,REFMODE,OCCURS,CHECKS,LAST
     1,OUTPUT1(2)
      COMMON /LENGTH/LINPUT,MAXSEG,ACTSEG
      COMMON /INPUT/RESPON(36)
      COMMON /STRING/SEG(100)
      COMMON /BREAKS/BRKLIST(2)
      COMMON /SUBAREAS/SUBNBR,SUBAREAS(64),SUBKEY(2)
      COMMON /QSCCB/QSCCB(130)
      COMMON /CCB/CCB(1000)
      COMMON /AREAOPEN/AREAOPEN(2),OPENMODE(2),STATUS
      COMMON /KEYBUF/KEYERR,KEYBUF(35),KEYBUF1(35)
      COMMON /RETURNAD/RETURNAD,CMDNBR,ABORTERR,ERRSET,ACTUALGR,MESSAGE
      COMMON /IOVALUE/EXECMOD,OUTMOD(5)
      COMMON /EXTRACT1/EXTRACT1(20)
      COMMON /TYPES/TYPES(8)
      COMMON /BUFFERS/BUFFERS(75)
      COMMON /BCOUNT/BCOUNT
      EQUIVALENCE(CCB(1),REFCODE),(CCB(2),PAGENO(1))
      EQUIVALENCE(CCB(4),LINENO),(CCB(5),FRSTREF)
      EQUIVALENCE(CCB(6),LASTREF),(CCB(7),GRPNO)
      EQUIVALENCE(CCB(8),ERRNO),(CCB(9),ERRREF)
      EQUIVALENCE(CCB(10),PASSWORD(1)),(CCB(12),AREANO)
      EQUIVALENCE(SEG1,SEG(3)),(SEG2,SEG(4))
      EQUIVALENCE(KEYBUF(9),PTR),(KEYBUF(10),WSI),(KEYBUF(11),TYPE)
      INTEGER PAGENO(2),PASSWORD(2)
      EQUIVALENCE(OUTPUT1(1),INPUT),(OUTPUT1(2),OUTPUT)
C WHEN CALLING EXTRACT WITH 2 WE HAVE
C  EXTRACT1:3-10 CONTAIN NAME
C  EXTRACT1 11:GROUPNO, 12:SIZE, 13:WSI, 16:TYPE IN ALPHA
C
C WHEN CALLING EXTRACT WITH 5 WE HAVE
C EXTRACT1: 11:TYPE, 12:WSI, 13:SIZE, 14:CONTROL ITEM
C           15:IF PICTURE,   16 IF RANGE 17:GROUPSYN
C
      EQUIVALENCE(WSI1,BUFFERS(1))
       DIRECT=4HDIRE
      VIA=4HVIA
      CALC=4HCALC
      ISAM=4HISAM
      IF(CMDNBR.NE.38) GOTO 10
      IF(ACTSEG.GT.1) CALL REFCOD(CCB(1))
      IF(ACTSEG.EQ.1) CALL REFCODES(CCB(1))
      AREA=IFIELD(CCB(1),0,8)
      GOTO 100
 10   CONTINUE
      TYPE2=EXTRACT1(16)
      IF(CMDNBR.GT.18 .AND.CMDNBR.LT.23)  GOTO 1
      CALL ASKGROUP
      TYPE2=EXTRACT1(16)
      WSI1=WSI
       AREA=EXTRACT1(2)
      IF(CMDNBR.EQ.12 .OR.CMDNBR.EQ.17) CALL ASKCURRENT(PTR); GOTO 100
       IF(CMDNBR.EQ.14) GOTO 14
       CALL MESS('   GROUP IS:',14);CALL MESS(EXTRACT1(16),4)
       CALL MES(' CONTROL ITEMS ARE:',18)
       IF(TYPE2.EQ.DIRECT) CALL REFCODES(CCB(1)); GOTO 100
  1    CALL ITEMLK
       IF(QSCCB(1).EQ.1) GOTO 100
       IF(IFIELD(QSCCB(71),8,1) .NE.1) GOTO 1
       CALL MODIFYLK
       IF(QSCCB(1).EQ.1) GOTO 1
      KEY=IFIELD(QSCCB(91),9,4)
       IF(TYPE2.EQ.ISAM)KEY=SCHMABIT(IFIELD(QSCCB(94),15,17),19,1)
       IF(TYPE2.EQ.CALC .AND.KEY.EQ.2)        GOTO 5
       IF(TYPE2.EQ.ISAM .AND.KEY.EQ.1)        GOTO 5
       IF(TYPE2.EQ.VIA .AND.KEY.GT.3) GOTO 5
       GOTO 2
 5     CONTINUE
      MESSAGE=1
      COUNT=1
      CONTROL=0
      IF(CMDNBR.GT.18 .AND.CMDNBR.LT.23) CONTROL=1
      CALL ASKITEM(COUNT,CONTROL)
       GOTO 1
C
C
 100   CONTINUE
      IF(CMDNBR.GT.17.AND.CMDNBR.LT.23)    RETURN
      IF(EXECMODE.EQ.3) RETURN
      IF(CHECKS.EQ.0) GOTO 999
      J1=1
      IF(AREA.GT.31) J1=2; AREA=AREA-32
      IF(IFIELD(AREAOPEN(J1),AREA,1).NE.1)
     1CALL MES('***AREA OF GROUP IS NOT OPENED.',40) ;GOTO RETURNAD
       IF(CMDNBR.NE.12 .OR.CMDNBR.NE.17) GOTO 999
       IF(CCB(KEYBUF1(1)/4+1).EQ.0)
     1CALL MES('***CURRENT OF TYPE IS NOT PRESENT.',40);GOTO RETURNAD
 999  CONTINUE
      IF(CMDNBR.EQ.12) CALL FINDC1(CCB,WSI1,1); RETURN
      IF(CMDNBR.EQ.38) CALL FINDD; RETURN
      IF(CMDNBR.EQ.14) CALL FINDDUP1(CCB,WSI1,1); RETURN
      IF(CMDNBR.EQ.17) CALL GET1(CCB,WSI1,1); RETURN
      CALL FINDG1(CCB,WSI1,1)
      RETURN
C
C--------------------FINDDUP. CHECKING VALIDITY------------C
 14    CONTINUE
      IF(CHECKS.EQ.0) GOTO 999
       IF(TYPE2.NE.CALC) GOTO 140
 141   CONTINUE
       CALL MEMBERLK
       IF(SCHMABIT(IFIELD(QSCCB(105),15,17)+1,0,10).NE.1000) GOTO 141
       IF(IFIELD(QSCCB(101),26,1).NE.1) GOTO 140
       GOTO 100
 140   CONTINUE
       CALL MES('***THIS IS NOT A RANDOMX GROUP.',32)
       GOTO RETURNAD
      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      *121-130      ALIAS                       *         *
C      *******************************************         *
C***********************************************************
      IMPLICIT INTEGER (A-Z)
      COMMON /QSCCB/QSCCB(130)
      EQUIVALENCE(QSCCB(3),AREAPTR)
      EQUIVALENCE(QSCCB(4),ISAMPTR)
      EQUIVALENCE(QSCCB(5),GROUPTR)
      EQUIVALENCE(QSCCB(6),ITEMPTR)
      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=SCHMABIT(I,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(SCHMABIT((SUBPTR),0,8).EQ.CODE)   GOTO 200
      IF(SCHMABIT((SUBPTR),0,8).EQ.MASTER)   GOTO 300
      QSCCB(1)=5
      RETURN
 300  QSCCB(1)=1
      QSCCB(14)=MASTER
      RETURN
 200  CONTINUE
      CALL SCHMABUF(QSCCB(PTRWSI),SUBPTR,SIZE)
      QSCCB(PTRCCB)=SUBPTR
      QSCCB(1)=0
      QSCCB(14)=CODE
      RETURN
 500  QSCCB(1)=6
      RETURN
 8    CONTINUE
 9    CONTINUE
 10   CONTINUE
      RETURN
 14   CONTINUE
      QSCCB(13)=0
      GOTO 4
      ENTRY MODIFYLK
      SUBPTR=0
 6    CONTINUE
      SIZE=5
      PTRWSI=91
      CODE=6
      MASTER=5
      PTRCCB=12
      IF(SUBPTR.NE.0) GOTO 100
      IF(MODIFYPTR.EQ.0) SUBPTR=IFIELD(QSCCB(73),15,17); GOTO 100
      SUBPTR=IFIELD(QSCCB(93),15,17); GOTO 100
C
      ENTRY CONTROLK
      SUBPTR=0
 140  CONTINUE
      SIZE=5
      CODE=6
      MASTER=4
      PTRCCB=8
      PTRWSI=91
      IF(SUBPTR.NE.0) GOTO 100
      IF(CONTROLPTR.EQ.0) SUBPTR=IFIELD(QSCCB(102),15,17); GOTO 100
      SUBPTR=IFIELD(QSCCB(93),15,17); GOTO 100
C
      ENTRY ALIASET
      SUBPTR=0
 12   CONTINUE
      SIZE=3
      CODE=12
      MASTER=4
      PTRCCB=11
      PTRWSI=121
      IF(SUBPTR.NE.0) GOTO 100
      IF(ALIASPTR.EQ.0) SUBPTR=IFIELD(QSCCB(107),15,17); GOTO 100
      SUBPTR=IFIELD(QSCCB(121),15,17); GOTO 100
C
      ENTRY CHECKLK
      SUBPTR=0
 11   CONTINUE
      SIZE=9
      CODE=11
      MASTER=5
      PTRCCB=7
      PTRWSI=81
      IF(SUBPTR.NE.0) GOTO 100
      IF(CHECKPTR.EQ.0) SUBPTR=IFIELD(QSCCB(77),15,17); GOTO 100
      SUBPTR=IFIELD(QSCCB(121),15,17); GOTO 100
      END
       SUBROUTINE IFINDX2
      IMPLICIT INTEGER(A-Z)
      COMMON /COMMAND/C(96),OTHERS(56)
      COMMON /IOTABLE/DEVICE,OUTMODE,EXECMODE,REFMODE,OCCURS,CHECKS,LAST
     1,OUTPUT1(2)
      COMMON /LENGTH/LINPUT,MAXSEG,ACTSEG
      COMMON /INPUT/RESPON(36)
      COMMON /STRING/SEG(100)
      COMMON /BREAKS/BRKLIST(2)
      COMMON /SUBAREAS/SUBNBR,SUBAREAS(64),SUBKEY(2)
      COMMON /QSCCB/QSCCB(130)
      COMMON /CCB/CCB(1000)
      COMMON /AREAOPEN/AREAOPEN(2),OPENMODE(2),STATUS
      COMMON /KEYBUF/KEYERR,KEYBUF(35),KEYBUF1(35)
      COMMON /RETURNAD/RETURNAD,CMDNBR,ABORTERR,ERRSET,ACTUALGR,MESSAGE
      COMMON /IOVALUE/EXECMOD,OUTMOD(5)
      COMMON /EXTRACT1/EXTRACT1(20)
      COMMON /TYPES/TYPES(8)
      COMMON /BUFFERS/BUFFERS(75)
      COMMON /BCOUNT/BCOUNT
      EQUIVALENCE(CCB(1),REFCODE),(CCB(2),PAGENO(1))
      EQUIVALENCE(CCB(4),LINENO),(CCB(5),FRSTREF)
      EQUIVALENCE(CCB(6),LASTREF),(CCB(7),GRPNO)
      EQUIVALENCE(CCB(8),ERRNO),(CCB(9),ERRREF)
      EQUIVALENCE(CCB(10),PASSWORD(1)),(CCB(12),AREANO)
      EQUIVALENCE(SEG1,SEG(3)),(SEG2,SEG(4))
      EQUIVALENCE(KEYBUF(9),PTR),(KEYBUF(10),WSI),(KEYBUF(11),TYPE)
      INTEGER PAGENO(2),PASSWORD(2)
      EQUIVALENCE(OUTPUT1(1),INPUT),(OUTPUT1(2),OUTPUT)
C WHEN CALLING EXTRACT WITH 2 WE HAVE
C  EXTRACT1:3-10 CONTAIN NAME
C  EXTRACT1 11:GROUPNO, 12:SIZE, 13:WSI, 16:TYPE IN ALPHA
C
C WHEN CALLING EXTRACT WITH 5 WE HAVE
C EXTRACT1: 11:TYPE, 12:WSI, 13:SIZE, 14:CONTROL ITEM
C           15:IF PICTURE,   16 IF RANGE 17:GROUPSYN
C
      EQUIVALENCE(WSI1,BUFFERS(1))
      EQUIVALENCE(TYPE2,EXTRACT1(16))
 10   CONTINUE
      CALL ASKGROUP
      WSI1=WSI
      COUNT=1
       AREA=EXTRACT1(2)
       IF(EXTRACT1(17).EQ.1) GOTO 1
       GOTO RETURNAD
  1    CALL ITEMLK
       IF(QSCCB(1).EQ.1) GOTO 100
       IF(IFIELD(QSCCB(71),12,1).NE.1) GOTO 1
       IF(ACTSEG.LT.3) GOTO 5
       CALL EXTRACT(5)
       DO 6 J=1,8
 6     IF(SEG(22+J).NE.EXTRACT1(2+J)) GOTO 1
 5     CONTINUE
       MESSAGE=1
       COUNT=1
       CALL ASKITEM(COUNT,0)
C
 100   CONTINUE
      IF(EXECMODE.EQ.3) RETURN
      IF(CHECKS.EQ.0) GOTO 999
      J1=1
      IF(AREA.GT.31) J1=2; AREA=AREA-32
      IF(IFIELD(AREAOPEN(J1),AREA,1).NE.1)
     1CALL MES('***AREA OF GROUP IS NOT OPENED.',40) ;GOTO RETURNAD
 999  CONTINUE
      IF(COUNT.EQ.1)
     1CALL MES('***INDEX ITEM NAME NOT SUPPLIED.',40);GOTO RETURNAD
      CALL FINDX1(CCB,WSI1,BUFFERS(2),RETURNAD)
      CALL FINDD
      IF(OUTMODE.GT.2) STATUS=1;CALL GROUPSYN(1)
      IF(OUTMODE.EQ.1 .OR.OUTMODE.EQ.3) GOTO 110
      CALL GET1(CCB,WSI1,1)
      IF(OUTMODE.EQ.5) CALL IPRINT(QSCCB(5))
 110  CONTINUE
      IF(CMDNBR.EQ.72) GOTO 100
      RETURN
      END
      SUBROUTINE ILINK
      IMPLICIT INTEGER(A-Z)
      COMMON /COMMAND/C(96),OTHERS(56)
      COMMON /IOTABLE/DEVICE,OUTMODE,EXECMODE,REFMODE,OCCURS,CHECKS,LAST
     1,OUTPUT1(2)
      COMMON /LENGTH/LINPUT,MAXSEG,ACTSEG
      COMMON /INPUT/RESPON(36)
      COMMON /STRING/SEG(100)
      COMMON /BREAKS/BRKLIST(2)
      COMMON /SUBAREAS/SUBNBR,SUBAREAS(64),SUBKEY(2)
      COMMON /QSCCB/QSCCB(130)
      COMMON /CCB/CCB(1000)
      COMMON /AREAOPEN/AREAOPEN(2),OPENMODE(2),STATUS
      COMMON /KEYBUF/KEYERR,KEYBUF(35),KEYBUF1(35)
      COMMON /RETURNAD/RETURNAD,CMDNBR,ABORTERR,ERRSET,ACTUALGR,MESSAGE
      COMMON /EXTRACT1/EXTRACT1(20)
      COMMON /TYPES/TYPES(8)
      COMMON /BUFFERS/BUFFERS(75)
      COMMON /BCOUNT/BCOUNT
      EQUIVALENCE(CCB(1),REFCODE),(CCB(2),PAGENO(1))
      EQUIVALENCE(CCB(4),LINENO),(CCB(5),FRSTREF)
      EQUIVALENCE(CCB(6),LASTREF),(CCB(7),GRPNO)
      EQUIVALENCE(CCB(8),ERRNO),(CCB(9),ERRREF)
      EQUIVALENCE(CCB(10),PASSWORD(1)),(CCB(12),AREANO)
      EQUIVALENCE(SEG1,SEG(3)),(SEG2,SEG(4))
      EQUIVALENCE(KEYBUF(9),PTR),(KEYBUF(10),WSI),(KEYBUF(11),TYPE)
      INTEGER PAGENO(2),PASSWORD(2)
      EQUIVALENCE(OUTPUT1(1),INPUT),(OUTPUT1(2),OUTPUT)
      EQUIVALENCE(WSIG,BUFFERS(74)),(WSIS,BUFFERS(75))
      EQUIVALENCE(SETNAME,SEG(90))
      CALL FMVC(SETNAME,0,SEG(23),0,32)
      CALL ASKGROUP
      AREAG=EXTRACT1(2)
      WSIG=WSI
      PTR1=PTR
      ACTUALGROUP=UNMAP(PTR)
      IF(ACTSEG.EQ.2) ACTSEG=1
      IF(ACTSEG.EQ.3) ACTSEG=2
      CALL FMVC(SEG(13),0,SETNAME,0,32)
      CALL ASKSET
      WSIS=WSI
      I=CMDNBR-18
      IF(CHECKS.EQ.0) GOTO (110,110,999),I
      CALL CHECKLINK
      MASTERPTR=SCHMABIT(IFIELD(QSCCB(105),15,17)+2,15,17)
      IF(CMDNBR.EQ.21) GOTO 120
      IF(IFIELD(QSCCB(101),9,1).EQ.1 .OR.IFIELD(QSCCB(101),10,1).EQ.1)
     1GOTO 120
      CALL MES('***PROCEDURE VALID ONLY WITH LINKAGE MANUAL OR OPTIONAL'
     1,62)
      GOTO RETURNAD
 120  CONTINUE
      MESSAGE=1
      CALL MES('       CONTROL ITEMS.',30)
      IF(IFIELD(QSCCB(101),29,1).EQ.1) CALL ASKCURRENT(MASTERPTR);
     1GOTO 100
 99   CONTINUE
      CALL FINDIRECT(MASTERPTR)
      CALL EXTRACT(2)
      CALL IFINDG
 100  CONTINUE
      CALL ICHKUPDATE(AREAG)
 999  CONTINUE
      IF(EXECMODE.EQ.3) RETURN
      IF(CMDNBR.EQ.21) CALL RELINK1(CCB,WSIG,2)
     1;CALL MES(' RELINKED.',12); RETURN
  110 CONTINUE
      IF(EXECMODE.EQ.3) RETURN
      IF(CMDNBR.EQ.19) CALL LINK1(CCB,WSIG,2); CALL MES('  LINKED.',8)
      IF(CMDNBR.EQ.20) CALL DELINK1(CCB,WSIG,2); CALL MES('  DELINKED',
     112)
      RETURN
C
      ENTRY CHECKLINK
 200  CONTINUE
      CALL MEMBERLK
      IF(QSCCB(1).EQ.1) GOTO 300
      IF(UNMAP(IFIELD(QSCCB(105),15,17)).NE.PTR)   GOTO 200
      RETURN
 300  CALL MES('***THE GROUP IS NOT A MEMBER OF THE SET.',40)
      GOTO RETURNAD
C
       END
      SUBROUTINE IPRINT(GROUPTR)
      IMPLICIT INTEGER(A-Z)
      COMMON /COMMAND/C(96),OTHERS(56)
      COMMON /IOTABLE/DEVICE,OUTMODE,EXECMODE,REFMODE,OCCURS,CHECKS,LAST
     1,OUTPUT1(2)
      COMMON /LENGTH/LINPUT,MAXSEG,ACTSEG
      COMMON /INPUT/RESPON(36)
      COMMON /STRING/SEG(100)
      COMMON /BREAKS/BRKLIST(2)
      COMMON /SUBAREAS/SUBNBR,SUBAREAS(64),SUBKEY(2)
      COMMON /QSCCB/QSCCB(130)
      COMMON /CCB/CCB(1000)
      COMMON /AREAOPEN/AREAOPEN(2),OPENMODE(2),STATUS
      COMMON /KEYBUF/KEYERR,KEYBUF(35),KEYBUF1(35)
      COMMON /RETURNAD/RETURNAD,CMDNBR,ABORTERR,ERRSET,ACTUALGR,MESSAGE
      COMMON /IOVALUE/EXECMOD,OUTMOD(5)
      COMMON /EXTRACT1/EXTRACT1(20)
      COMMON /TYPES/TYPES(8)
      EQUIVALENCE(CCB(1),REFCODE),(CCB(2),PAGENO(1))
      EQUIVALENCE(CCB(4),LINENO),(CCB(5),FRSTREF)
      EQUIVALENCE(CCB(6),LASTREF),(CCB(7),GRPNO)
      EQUIVALENCE(CCB(8),ERRNO),(CCB(9),ERRREF)
      EQUIVALENCE(CCB(10),PASSWORD(1)),(CCB(12),AREANO)
      EQUIVALENCE(KEYBUF(9),PTR),(KEYBUF(10),WSI),(KEYBUF(11),TYPE)
      INTEGER PAGENO(2),PASSWORD(2)
      EQUIVALENCE(OUTPUT1(1),INPUT),(OUTPUT1(2),OUTPUT)
      EQUIVALENCE(ITYPE,EXTRACT1(11)),(IWSI,EXTRACT1(12))
      EQUIVALENCE(ISIZE,EXTRACT1(13)),(ICONTRL,EXTRACT1(14))
      EQUIVALENCE(ICHECK1,EXTRACT1(15)),(ICHECK2,EXTRACT1(16))
      EQUIVALENCE(ISYN,EXTRACT1(17)),(INEXT,EXTRACT1(18))
      EQUIVALENCE(GTYPE,EXTRACT1(16)),(GSYN,EXTRACT1(11))
      EQUIVALENCE(GSIZE,EXTRACT1(12)),(GWSI,EXTRACT1(13))
      EQUIVALENCE(GRANGE1,EXTRACT1(14)),(GRANGE2,EXTRACT1(15))
      EQUIVALENCE(GINDEX,EXTRACT1(17)),(GSTAT,EXTRACT1(18))
      EQUIVALENCE(GAREA,EXTRACT1(2))
C
      CALL FINDIRECT(GROUPTR)
 3    CONTINUE
      CALL EXTRACT(2)
      GROUPNO=GSYN
 1    CONTINUE
      CALL ITEMLK
      IF(QSCCB(1).EQ.1) RETURN
      CALL EXTRACT(5)
      IF(GROUPNO.NE.ISYN) RETURN
      IF(IWSI.EQ.INEXT) GOTO 1
C     IF(ITYPE.EQ.2) ITYPE=0
C     IF(ITYPE.EQ.3) ITYPE=1
      IF(ITYPE.EQ.7)          ISIZE=ISIZE*2-1
      OCCUR=ISIZE
      IF(ITYPE.EQ.4 .OR.ITYPE.EQ.5) ISIZE=4
      IF(ITYPE.EQ.6) ISIZE=8
      IF(OUTPUT.EQ.-1) ITYPE=8
      KEYBUF(1)=0
      DO 2 J=2,35
 2    KEYBUF(J)=4H
      IF(OCCURS*ISIZE .LT.OCCUR) OCCUR=OCCURS*ISIZE
      I=1
      DO 20 L=1,OCCUR,ISIZE
      IF(OCCUR.GT.ISIZE) EXTRACT1(5)=4H      ; EXTRACT1(6)=4H      ;
     1CALL INDISP(EXTRACT1(5),3,4,I,0,4,8); EXTRACT1(5)=4H -
      CALL INDISP(KEYBUF(1),3,ITYPE,CCB,IWSI,ISIZE,8)
      M=2+KEYBUF(1)/4
      WRITE(108,14)(EXTRACT1(L),L=3,6),M,(KEYBUF(L),L=2,M)
      IWSI=IWSI+ISIZE
      I=I+1
 20   CONTINUE
      GOTO 1
C
      ENTRY SHOWGRP
 10   CONTINUE
      IF(ACTSEG.EQ.1)
     1CALL QUAANSB('  GROUP NAME:',14,1,SEG(13),0,RETURNAD,31)
      CALL READV(1,KEYBUF,L,SEG(13),31,500S)
      IF(TYPE.NE.2) GOTO 500
      CALL FINDIRECT(PTR)
      GOTO 3
 500  CALL MES('***THIS IS NOT A GROUP NAME.RETRY.',40)
      ACTSEG=1; GOTO 10
      END
C**************************************************************
      SUBROUTINE GROUPSYN(L)
      IMPLICIT INTEGER(A-Z)
      COMMON /COMMAND/C(96),OTHERS(56)
      COMMON /IOTABLE/DEVICE,OUTMODE,EXECMODE,REFMODE,OCCURS,CHECKS,LAST
     1,OUTPUT1(2)
      COMMON /LENGTH/LINPUT,MAXSEG,ACTSEG
      COMMON /INPUT/RESPON(36)
      COMMON /STRING/SEG(100)
      COMMON /BREAKS/BRKLIST(2)
      COMMON /SUBAREAS/SUBNBR,SUBAREAS(64),SUBKEY(2)
      COMMON /QSCCB/QSCCB(130)
      COMMON /CCB/CCB(1000)
      COMMON /AREAOPEN/AREAOPEN(2),OPENMODE(2),STATUS
      COMMON /KEYBUF/KEYERR,KEYBUF(35),KEYBUF1(35)
      COMMON /RETURNAD/RETURNAD,CMDNBR,ABORTERR,ERRSET,ACTUALGR,MESSAGE
      COMMON /IOVALUE/EXECMOD,OUTMOD(5)
      COMMON /EXTRACT1/EXTRACT1(20)
      COMMON /TYPES/TYPES(8)
      EQUIVALENCE(CCB(1),REFCODE),(CCB(2),PAGENO(1))
      EQUIVALENCE(CCB(4),LINENO),(CCB(5),FRSTREF)
      EQUIVALENCE(CCB(6),LASTREF),(CCB(7),GRPNO)
      EQUIVALENCE(CCB(8),ERRNO),(CCB(9),ERRREF)
      EQUIVALENCE(CCB(10),PASSWORD(1)),(CCB(12),AREANO)
      EQUIVALENCE(SEG1,SEG(3)),(SEG2,SEG(4))
      EQUIVALENCE(KEYBUF(9),PTR),(KEYBUF(10),WSI),(KEYBUF(11),TYPE)
      INTEGER PAGENO(2),PASSWORD(2)
      EQUIVALENCE(OUTPUT1(1),INPUT),(OUTPUT1(2),OUTPUT)
      INTEGER MESSAGES(6)
      DATA MESSAGES/24HGROUP FOUND:GROUP STORED/
      IF(CMDNBR.EQ.22) L5=4;L6=6
      CALL FINDIRECT(0)
      IF(QSCCB(1).NE.0) CALL MES('***SUBSCHEMA NOT AVAILABLE.',27);
     1RETURN
 301  CALL AREALK
      IF(QSCCB(1).EQ.1) RETURN
 302  CALL GROUPLK
      IF(QSCCB(1).EQ.1) GOTO 301
      IF(IFIELD(QSCCB(62),0,10).NE.CCB(7)) GOTO 302
      CALL EXTRACT(2)
C     I=IFIELD(REFCODE,8,24)
      IF(L.EQ.0) RETURN
      I1=IFIELD(CCB(1),0,8); I2=IFIELD(CCB(1),8,24)
      CALL FMVC(CCB(2),0,CCB(2),3,1)
      WRITE(108,1)(MESSAGES(S),S=L5,L6),
     1EXTRACT1(3),EXTRACT1(4),CCB(7),I1,I2,EXTRACT1(2),CCB(2),CCB(3),
     1LINENO
 1    FORMAT(1X,3A4,1X,2A4,'  SYN:',I4,' REF: ',
     1I2,3H  -  ,I7,4H  OR,I3,'-',A1,A4,'-',A3)
      RETURN
      END
C
C*********************************************************
      SUBROUTINE ASKCURRENT(GROUPTR)
      IMPLICIT INTEGER(A-Z)
      COMMON /COMMAND/C(96),OTHERS(56)
      COMMON /IOTABLE/DEVICE,OUTMODE,EXECMODE,REFMODE,OCCURS,FIRST,LAST
     1,INPUT
      COMMON /LENGTH/LINPUT,MAXSEG,ACTSEG
      COMMON /INPUT/RESPON(36)
      COMMON /STRING/SEG(100)
      COMMON /BREAKS/BRKLIST(2)
      COMMON /SUBAREAS/SUBNBR,SUBAREAS(64),SUBKEY(2)
      COMMON /QSCCB/QSCCB(130)
      COMMON /CCB/CCB(1000)
      COMMON /AREAOPEN/AREAOPEN(2),OPENMODE(2),STATUS
      COMMON /KEYBUF/KEYERR,KEYBUF(35),KEYBUF1(35)
      COMMON /RETURNAD/RETURNAD,CMDNBR,ABORTERR,ERRSET
      COMMON /IOVALUE/EXECMOD,OUTMOD(5)
      COMMON /EXTRACT1/EXTRACT1(20)
      COMMON /TYPES/TYPES(8)
      EQUIVALENCE(CCB(1),REFCODE),(CCB(2),PAGENO(1))
      EQUIVALENCE(CCB(4),LINENO),(CCB(5),FRSTREF)
      EQUIVALENCE(CCB(6),GRPNO),(CCB(7),ERRCODE)
      EQUIVALENCE(CCB(10),PASSWORD(1)),(CCB(12),AREANO)
      EQUIVALENCE(SEG1,SEG(3)),(SEG2,SEG(4))
      EQUIVALENCE(KEYBUF(9),PTR),(KEYBUF(10),WSI),(KEYBUF(11),TYPE)
      INTEGER PAGENO(2),PASSWORD(2)
      CALL FINDIRECT(GROUPTR)
      CALL EXTRACT(2)
      KEYBUF1(1)=(EXTRACT1(12)+EXTRACT1(13))*4-4
      KEYBUF1(2)=5
      CALL READV(1,RESPON,L,KEYBUF1,8,800S)
      CALL MESS(RESPON,12)
      CALL REFCODES(CCB(KEYBUF1(1)/4+1))
      RETURN
C
 800  CONTINUE
      CALL MES('***BAD PROGRAM OR BAD FILES.',30)
      RETURN
      END
       SUBROUTINE ASKGROUP
      IMPLICIT INTEGER(A-Z)
      COMMON /COMMAND/C(96),OTHERS(56)
      COMMON /IOTABLE/DEVICE,OUTMODE,EXECMODE,REFMODE,OCCURS,CHECKS,LAST
     1,OUTPUT1(2)
      COMMON /LENGTH/LINPUT,MAXSEG,ACTSEG
      COMMON /INPUT/RESPON(36)
      COMMON /STRING/SEG(100)
      COMMON /BREAKS/BRKLIST(2)
      COMMON /SUBAREAS/SUBNBR,SUBAREAS(64),SUBKEY(2)
      COMMON /QSCCB/QSCCB(130)
      COMMON /CCB/CCB(1000)
      COMMON /AREAOPEN/AREAOPEN(2),OPENMODE(2),STATUS
      COMMON /KEYBUF/KEYERR,KEYBUF(35),KEYBUF1(35)
      COMMON /RETURNAD/RETURNAD,CMDNBR,ABORTERR,ERRSET,ACTUALGR,MESSAGE
      COMMON /IOVALUE/EXECMOD,OUTMOD(5)
      COMMON /EXTRACT1/EXTRACT1(20)
      COMMON /TYPES/TYPES(8)
      COMMON /BUFFERS/BUFFERS(75)
      COMMON /BCOUNT/BCOUNT
      EQUIVALENCE(CCB(1),REFCODE),(CCB(2),PAGENO(1))
      EQUIVALENCE(CCB(4),LINENO),(CCB(5),FRSTREF)
      EQUIVALENCE(CCB(6),LASTREF),(CCB(7),GRPNO)
      EQUIVALENCE(CCB(8),ERRNO),(CCB(9),ERRREF)
      EQUIVALENCE(CCB(10),PASSWORD(1)),(CCB(12),AREANO)
      EQUIVALENCE(SEG1,SEG(3)),(SEG2,SEG(4))
      INTEGER PAGENO(2),PASSWORD(2)
      EQUIVALENCE(OUTPUT1(1),INPUT),(OUTPUT1(2),OUTPUT)
      DATA ONELEFT/8Z80000000/
 10   CONTINUE
       IF(ACTSEG.EQ.1)
     1CALL QUAANSB('  GROUP NAME: ',14,1,SEG(13),0,RETURNAD,31)
       CALL READV(1,KEYBUF,L,SEG(13),31,500S)
       IF(TYPE.NE.2) GOTO 500
       CALL FINDIRECT(PTR)
       WSI1=WSI
       CALL EXTRACT(2)
      RETURN
C
      ENTRY ASKSET
      IF(ACTSEG.GT.1) GOTO 240
 231  CONTINUE
      CALL QUAANSB(
     1'   SET NAME:',12,1,SEG(13),0,RETURNAD,32)
 240  CONTINUE
      CALL READV(1,KEYBUF,L,SEG(13),31,800S)
      IF(TYPE.NE.3) GOTO 800
 241  CONTINUE
      CALL FINDIRECT(PTR)
      CALL EXTRACT(TYPE)
      RETURN
 800  CONTINUE
      CALL MESS('***THIS IS NOT A SET NAME:',28)
      ACTSEG=1; GOTO 231
C
C
 500   CONTINUE
       CALL MES('***THIS IS NOT A GROUP NAME.RETRY.',40)
       ACTSEG=1; GOTO 10
C
      ENTRY ICHKUPDATE(AREA)
      J1=1
      IF(AREA.GT.31) J1=2; AREA=AREA-32
      IF(IFIELD(AREAOPEN(J1),AREA,1).NE.1)
     1CALL MES('***AREA OF GROUP IS NOT OPENED.',40) ;GOTO RETURNAD
       IF(IFIELD(OPENMODE(J1),AREA,1).NE.1)
     1CALL MES('***AREA OF GROUP NOT OPENED IN UPDATE MODE.',52);
     1GOTO RETURNAD
      RETURN
C
C
      ENTRY ASKITEM(COUNT,CONTROL)
C M=1 IF ITEM ENTERED IS NOT EMPTY, CONTROL=1 IF CONTROL ITEM IS ASKED
       CALL EXTRACT(5)
       TYPE3=EXTRACT1(11)
       EXTRACT1(11)=TYPES(EXTRACT1(11)+1)
       LENGTH=EXTRACT1(13)
       IF(TYPE3.EQ.7)        LENGTH=LENGTH*2-1
      SIZE=LENGTH
      IF(TYPE3.EQ.6) SIZE=8
      OCCUR=LENGTH
       IF(TYPE3.GT.3 .AND.TYPE3.LT.7) LENGTH=SIZE
       TYPE3=TYPE3*INPUT
       IF(INPUT.EQ.-1 .AND.TYPE3.EQ.0) TYPE3=-2
       WSI3=EXTRACT1(12)
       WSI4=WSI3
       EXTRACT1(13)=4H
       CALL INDISP(EXTRACT1(12),3,4,LENGTH,0,4,8)
       EXTRACT1(12)=4H ,
       EXTRACT1(12)=4H ,
      J1=0
       IF(CONTROL.EQ.1) CALL CNTITEM
      IF(J1.EQ.1) RETURN
       IF(OCCURS*SIZE.LT.OCCUR) OCCUR=OCCURS*SIZE
       I=1; M=0
       DO 20 L=1,OCCUR,SIZE
       IF(OCCUR.GT.SIZE) CALL INDISP(EXTRACT1(7),3,4,I,0,4,8);
     1EXTRACT1(7)=4H -
       CALL QUAANSB(EXTRACT1(3),48,TYPE3,CCB,WSI3,21S,LENGTH)
      M=1
 21    I=I+1
       WSI3=WSI3+SIZE
 20    CONTINUE
      IF((M.EQ.1).AND.((COUNT+1).LE.BCOUNT))
     1COUNT=COUNT+1;BUFFERS(COUNT)=WSI4
      IF (COUNT.GT.BCOUNT) GO TO 30
      IF(M.EQ.1 .AND.(TYPE3*INPUT.GT.3 .AND.TYPE3*INPUT.LT.7))
     1CALL FMVC(BUFFERS(COUNT),0,ONELEFT,0,1)
      RETURN
 30   CALL MES('***TOO MANY ITEMS FOR BUFFERS',28)
      GOTO RETURNAD
C
      ENTRY CNTITEM
      IF(UNMAP(IFIELD(QSCCB(75),15,17)).EQ.ACTUALGROUP) RETURN
      CALL READV(1,KEYBUF1,L,UNMAP(IFIELD(QSCCB(75),15,17)),4,300S)
      IF(MESSAGE.EQ.0) MESSAGE=1; CALL MES('          CONTROL ITEMS',24)
       EXTRACT1(7)=4H /
      CALL FMVC(EXTRACT1(8),0,KEYBUF1(1),0,12)
      IF(IFIELD(QSCCB(71),15,17).NE.0) RETURN
      CALL FMVC(EXTRACT1(3),0,'REFCODE       ',0,12)
      CALL MESS(EXTRACT1(3),32)
      CALL REFCODES(CCB(1))
      J1=1
      RETURN
 300  CONTINUE
      CALL MES('***BAD PROGRAM',15)
      GOTO RETURNAD
      END
       SUBROUTINE ISTORE
      IMPLICIT INTEGER(A-Z)
      COMMON /COMMAND/C(96),OTHERS(56)
      COMMON /IOTABLE/DEVICE,OUTMODE,EXECMODE,REFMODE,OCCURS,CHECKS,LAST
     1,OUTPUT1(2)
      COMMON /LENGTH/LINPUT,MAXSEG,ACTSEG
      COMMON /INPUT/RESPON(36)
      COMMON /STRING/SEG(100)
      COMMON /BREAKS/BRKLIST(2)
      COMMON /SUBAREAS/SUBNBR,SUBAREAS(64),SUBKEY(2)
      COMMON /QSCCB/QSCCB(130)
      COMMON /CCB/CCB(1000)
      COMMON /AREAOPEN/AREAOPEN(2),OPENMODE(2),STATUS
      COMMON /KEYBUF/KEYERR,KEYBUF(35),KEYBUF1(35)
      COMMON /RETURNAD/RETURNAD,CMDNBR,ABORTERR,ERRSET,ACTUALGR,MESSAGE
      COMMON /IOVALUE/EXECMOD,OUTMOD(5)
      COMMON /EXTRACT1/EXTRACT1(20)
      COMMON /TYPES/TYPES(8)
      COMMON /BUFFERS/BUFFERS(75)
      COMMON /BCOUNT/BCOUNT
      EQUIVALENCE(CCB(1),REFCODE),(CCB(2),PAGENO(1))
      EQUIVALENCE(CCB(4),LINENO),(CCB(5),FRSTREF)
      EQUIVALENCE(CCB(6),LASTREF),(CCB(7),GRPNO)
      EQUIVALENCE(CCB(8),ERRNO),(CCB(9),ERRREF)
      EQUIVALENCE(CCB(10),PASSWORD(1)),(CCB(12),AREANO)
      EQUIVALENCE(SEG1,SEG(3)),(SEG2,SEG(4))
      EQUIVALENCE(KEYBUF(9),PTR),(KEYBUF(10),WSI),(KEYBUF(11),TYPE)
      INTEGER PAGENO(2),PASSWORD(2)
      EQUIVALENCE(OUTPUT1(1),INPUT),(OUTPUT1(2),OUTPUT)
C WHEN CALLING EXTRACT WITH 2 WE HAVE
C  EXTRACT1:3-10 CONTAIN NAME
C  EXTRACT1 11:GROUPNO, 12:SIZE, 13:WSI, 16:TYPE IN ALPHA
C
C WHEN CALLING EXTRACT WITH 5 WE HAVE
C EXTRACT1: 11:TYPE, 12:WSI, 13:SIZE, 14:CONTROL ITEM
C           15:IF PICTURE,   16 IF RANGE 17:GROUPSYN
C
      EQUIVALENCE(TYPE2,EXTRACT1(16))
      EQUIVALENCE(WSI1,BUFFERS(1))
       CALL ASKGROUP
       GROUPNO=EXTRACT1(11)
       TYPE1=TYPE2
       DIRECT=4HDIRE
       ISAM=4HISAM
       VIA=4HVIA
      WSI1=WSI
       ACTUALGROUP=UNMAP(PTR)
       MESSAGE=0
       AREA=EXTRACT1(2)
       CONTROL=0; COUNT=1;
      IF(EXECMODE.EQ.2) GOTO 100
       L=1; IF(CMDNBR.EQ.22) L=2
      IF(CMDNBR.EQ.18  .AND.ACTSEG.GT.2) GOTO 700
  1    CALL ITEMLK
       IF(QSCCB(1).EQ.1) GOTO (100,387),L
       IF(CMDNBR.EQ.22) GOTO 386
       IF(ISAM.NE.TYPE1) GOTO 386
       IF(CHECKS.NE.1) GOTO 386
 388   CONTINUE
       CALL MODIFYLK
       IF(QSCCB(1).EQ.1) GOTO 386
       IF(SCHMABIT(IFIELD(QSCCB(94),15,17),19,1).EQ.1) GOTO  1
       GOTO 388
 386   CONTINUE
       CALL ASKITEM(COUNT,CONTROL)
       GOTO 1
C
C
 100   CONTINUE
      IF(EXECMODE.EQ.3) RETURN
      IF(CHECKS.EQ.0) GOTO 999
       CALL ICHKUPDATE(AREA)
 999  CONTINUE
      IF(CMDNBR.EQ.22) CALL STORE1(CCB,WSI1,1);STATUS=1;CALL GROUPSYN(1)
      IF(CMDNBR.EQ.18) CALL MODIFY1(CCB,WSI1,COUNT);STATUS=1;
     1CALL MES('   MODIFIED.',12)
      RETURN
 387   IF(TYPE1.NE.DIRECT) GOTO 200
       MESSAGE=1; CALL MES('            CONTROL ITEMS     ',30)
       CALL MESS(' PRIMARY ',9);CALL REFCODES(CCB(1))
C
 200   CONTINUE
       CALL MEMBERLK
       MEMBERPTR=QSCCB(13)
 205   CONTINUE
       IF(QSCCB(1).EQ.1) GOTO 100
       IF(IFIELD(QSCCB(101),9,1).EQ.1.OR.IFIELD(QSCCB(101),10,1).EQ.1)
     1GOTO 206
      QSCCB(121)=QSCCB(104)
       QSCCB(9)=IFIELD(QSCCB(105),15,17)
       GRPTR=SCHMABIT(IFIELD(QSCCB(105),15,17)+2,15,17)
       GROUPNO2=IFIELD(QSCCB(102),0,10)
       IF(IFIELD(QSCCB(101),29,1).EQ.1) GOTO 202
      IF(GROUPNO2.EQ.GROUPNO.AND.SCHMABIT(GRPTR+1,0,10).GT.999)GOTO 206
      CALL FINDIRECT(GRPTR)
     130)
       CALL EXTRACT(2)
       CALL IFINDG
       GOTO 201
 202   CONTINUE
       IF(IFIELD(QSCCB(101),30,1).NE.1) GOTO 279
       IF(TYPE1.NE.VIA) GOTO 279
       IF(CHECKS.EQ.0) GOTO 279
       SETWSI=SCHMABIT(QSCCB(9),15,17)
      IF(CCB(SETWSI+1).EQ.0)
     1CALL MES('***MASTER OF A VIA GROUP HAS NOT BEEN RETRIEVED',60);
     1RETURN
 279  CONTINUE
       IF(MESSAGE.EQ.0) MESSAGE=1;
     1CALL  MES('         CONTROL ITEMS.',32)
       CALL ASKCURRENT(GRPTR)
 201   CONTINUE
       QSCCB(13)=MEMBERPTR
 206   CONTINUE
      GOTO 200
C HERE WE MODIFY: WE CALL ASKITEM ONLY IF ELEMENT IS SPECIFIED.
C
 700   CALL ITEMLK
       IF(QSCCB(1).EQ.1) GOTO 703
       M=0
       COUNT=1
       L=23
       DO 701 J=23,L,10
       M=M+1
       CALL EXTRACT(5)
       DO 702 I=1,8
       IF(SEG(J-1+I).NE.EXTRACT1(2+I)) GOTO 701
 702   CONTINUE
       QSCCB(120+M)=J
       IF(ISAM.NE.TYPE1 .OR.CHECKS.EQ.0) GOTO 710
 711   CALL MODIFYLK
       IF(QSCCB(1).EQ.1) GOTO 710
       IF(SCHMABIT(IFIELD(QSCCB(94),15,17),19,1).EQ.1)
     1CALL MES('***NOT ALLOWED TO MODIFY ISAM ITEM.',40); GOTO RETURNAD
       GOTO 711
 710   CONTINUE
       CALL ASKITEM(COUNT,0)
       GOTO 700
 701   CONTINUE
       GOTO 700
 703   CONTINUE
       DO 704 J=23,L,10
       DO 705 N=1,10
 705   IF(QSCCB(120+N).EQ.J) GOTO 704
       CALL MESS('***THIS IS NOT AN ITEM FOR THE GROUP.',40)
       CALL MES(SEG(J),32)
       CALL MES('***MODIFY  NOT EXECUTED.',32)
       GOTO RETURNAD
 704   CONTINUE
       GOTO 100
       END
      SUBROUTINE UPDATE
      IMPLICIT INTEGER(A-Z)
      COMMON /COMMAND/C(96),OTHERS(56)
      COMMON /IOTABLE/DEVICE,OUTMODE,EXECMODE,REFMODE,OCCURS,CHECKS,LAST
     1,OUTPUT1(2)
      COMMON /LENGTH/LINPUT,MAXSEG,ACTSEG
      COMMON /INPUT/RESPON(36)
      COMMON /STRING/SEG(100)
      COMMON /BREAKS/BRKLIST(2)
      COMMON /SUBAREAS/SUBNBR,SUBAREAS(64),SUBKEY(2)
      COMMON /QSCCB/QSCCB(130)
      COMMON /CCB/CCB(1000)
      COMMON /AREAOPEN/AREAOPEN(2),OPENMODE(2),STATUS
      COMMON /KEYBUF/KEYERR,KEYBUF(35),KEYBUF1(35)
      COMMON /RETURNAD/RETURNAD,CMDNBR,ABORTERR,ERRSET,ACTUALGR,MESSAGE
      COMMON /IOVALUE/EXECMOD,OUTMOD(5)
      COMMON /EXTRACT1/EXTRACT1(20)
      COMMON /TYPES/TYPES(8)
      EQUIVALENCE(CCB(1),REFCODE),(CCB(2),PAGENO(1))
      EQUIVALENCE(CCB(4),LINENO),(CCB(5),FRSTREF)
      EQUIVALENCE(CCB(6),LASTREF),(CCB(7),GRPNO)
      EQUIVALENCE(CCB(8),ERRNO),(CCB(9),ERRREF)
      EQUIVALENCE(CCB(10),PASSWORD(1)),(CCB(12),AREANO)
      EQUIVALENCE(SEG1,SEG(3)),(SEG2,SEG(4))
      EQUIVALENCE(KEYBUF(9),PTR),(KEYBUF(10),WSI),(KEYBUF(11),TYPE)
      INTEGER PAGENO(2),PASSWORD(2)
      EQUIVALENCE(OUTPUT1(1),INPUT),(OUTPUT1(2),OUTPUT)
      CALL ASKGROUP
      CALL ASKCURRENT(PTR)
      IF(EXECMODE.EQ.S) RETURN
      AREA=EXTRACT1(2)
      IF(CHECKS.EQ.1) CALL ICHKUPDATE(AREA)
      IF(CHECKS.EQ.1 .AND.CCB(KEYBUF1(1)/4+1).EQ.0)
     1CALL MES('***CURRENT OF TYPE HAS NOT BEEN RETRIEVED',60);
     1GOTO RETURNAD
      IF(CMDNBR.EQ.7) CALL DELETE1(CCB,WSI,1)
      IF(CMDNBR.EQ.8) CALL DELETA1(CCB,WSI,1)
      IF(CMDNBR.EQ.9) CALL DELETS1(CCB,WSI,1)
      IF(CMDNBR.EQ.10) CALL REMOVE1(CCB,WSI,1)
      IF(CMDNBR.EQ.11) CALL REMOVS1(CCB,WSI,1)
      CALL MES('    DELETED.',12)
      STATUS=1
      END
      SUBROUTINE IOPEN
      IMPLICIT INTEGER(A-Z)
      COMMON /COMMAND/C(96),OTHERS(56)
      COMMON /IOTABLE/DEVICE,OUTMODE,EXECMODE,REFMODE,OCCURS,CHECKS,LOCK
     1,OUTPUT1(2)
      COMMON /LENGTH/LINPUT,MAXSEG,ACTSEG
      COMMON /INPUT/RESPON(36)
      COMMON /STRING/SEG(100)
      COMMON /BREAKS/BRKLIST(2)
      COMMON /SUBAREAS/SUBNBR,SUBAREAS(64),SUBKEY(2)
      COMMON /QSCCB/QSCCB(130)
      COMMON /CCB/CCB(1000)
      COMMON /AREAOPEN/AREAOPEN(2),OPENMODE(2),STATUS
      COMMON /KEYBUF/KEYERR,KEYBUF(35),KEYBUF1(35)
      COMMON /RETURNAD/RETURNAD,CMDNBR,ABORTERR,ERRSET
      COMMON /IOVALUE/EXECMOD,OUTMOD(5)
      COMMON /EXTRACT1/EXTRACT1(20)
      COMMON /TYPES/TYPES(8)
      EQUIVALENCE(CCB(1),REFCODE),(CCB(2),PAGENO(1))
      EQUIVALENCE(CCB(4),LINENO),(CCB(5),FRSTREF)
      EQUIVALENCE(CCB(6),LASTREF),(CCB(7),GRPNO)
      EQUIVALENCE(CCB(8),ERRNO),(CCB(9),ERRREF)
      EQUIVALENCE(CCB(11),PASSWORD(1)),(CCB(13),AREANO)
      EQUIVALENCE(SEG1,SEG(3)),(SEG2,SEG(4))
      EQUIVALENCE(KEYBUF(9),PTR),(KEYBUF(10),WSI),(KEYBUF(11),TYPE)
      INTEGER PAGENO(2),PASSWORD(2)
      EQUIVALENCE(OUTPUT1(1),INPUT),(OUTPUT1(2),OUTPUT)
      DATA ONELEFT/8Z80000000/
C---CHECKING COMMAND VALIDITY AGAINST WORDS STATUS-----
      CALL READV(1,SUBNBR,L,SUBKEY,8,500S)
      IF(CHECKS.EQ.0) GOTO 999
      IF(STATUS.EQ.1 .AND.CMDNBR.NE.4)
     1CALL MES('***NO DMS OPEN IS ALLOWED AFTER PROCEDURAL CALLS.',56);
     1RETURN
 999  CONTINUE
      IF(ACTSEG.NE.1) GOTO 1
      IF(SUBNBR.GE.MAXSEG) CALL MES('***TOO MANY FILES.',20); RETURN
      J=13
      DO 2 J1=1,SUBNBR
      KEYBUF1(1)=SUBAREAS(J1*2-1)
      CALL READV(1,KEYBUF1,L,KEYBUF1,4,500S)
      CALL FMVC(SEG(J),0,KEYBUF1,0,32)
      ACTSEG=ACTSEG+1
      J=J+10
 2    CONTINUE
 1    CONTINUE
      IF(CMDNBR.EQ.6) GOTO 3
      IF(AREAOPEN(1).EQ.0 .AND.AREAOPEN(2).EQ.0)
     1CALL QUAANSB(' PASSWORD: ',11,1,PASSWORD,0,0,8)
      CALL MES(' ENTER CIPHER KEY FOR THE FOLLOWING AREAS:',42)
 3    CONTINUE
      I=ACTSEG*10
      DO 10 J=13,I,10
 21   CONTINUE
      CALL FMVC(KEYBUF1,0,SEG(J),0,32)
      CALL READV(1,KEYBUF,L,KEYBUF1,31,20S)
      IF(TYPE.EQ.1) SEG(J-1)=WSI;SEG(J-2)=PTR; GOTO 11
 20   CONTINUE
      CALL MESS('***THIS IS NOT AN AREA NAME: ',29)
      CALL MES(KEYBUF1,31)
      CALL QUAANSB('   RETRY: ',9,1,SEG(J),0,RETURNAD,32)
      GOTO 21
 11   CONTINUE
      J1=1
      DO 802 J2=1,SUBNBR
 802  IF(SEG(J-2).EQ.SUBAREAS(J2*2-1)) AREANO=SUBAREAS(J2*2)
      IF(AREANO.GT.31.) AREANO=AREANO-32
      IF(IFIELD(AREAOPEN(J1),AREANO,1).NE.1.AND.CMDNBR.EQ.6)
     1CALL MESS('***AREA NOT OPENED:',20); CALL MES(SEG(J),31);RETURN
      IF(IFIELD(AREAOPEN(J1),AREANO,1).EQ.1.AND.CMDNBR.NE.6)
     1CALL MESS('***AREA ALREADY OPENED:',30); CALL MES(SEG(J),31);
     1RETURN
 10   CONTINUE
C
C--- WHEN WE ARE HERE ALL THE AREA NAMES HAVE BEEN CHECKED--
C    IF THE EXECMODE IS NOT DIRECT OR IT IS NOT A CLOSE THE
C    CIPHER KEYS ARE ASKED.
C
      IF(EXECMODE.EQ.2 .OR.CMDNBR.EQ.6)
     1GOTO(101,102,103,104,105,106),CMDNBR
      DO 30 J=13,I,10
      CALL MESS(SEG(J),31); CALL QUAANSB(':',1,1,CCB,SEG(J-1),30S,4)
  30  CONTINUE
      IF(EXECMODE.EQ.3) RETURN
      GOTO(101,102,103,104,105,106),CMDNBR
 101  CONTINUE
 104  CONTINUE
 105  CONTINUE
      UPDATE=1
      GO TO 107
 102  CONTINUE
 103  CONTINUE
      MODE=1
      UPDATE=0
      GO TO 107
 106  CONTINUE
      MODE=0
      UPDATE=0
 107  CONTINUE
      DO 201 J=12,I,10
      WSI=SEG(J)/4+1
      COUNT=2
      KEYBUF1(1)=ONELEFT
      KEYBUF1(2)=SEG(J)
      IF(CMDNBR.EQ.1)     CALL OPENUPD1(CCB,KEYBUF1,COUNT)
      IF(CMDNBR.EQ.2)     CALL OPRETSH1(CCB,KEYBUF1,COUNT)
      IF(CMDNBR.EQ.3)     CALL OPENRET1(CCB,KEYBUF1,COUNT)
      IF(CMDNBR.EQ.4)     CALL OPUPDSH1(CCB,KEYBUF1,COUNT)
      IF(CMDNBR.EQ.5)     CALL CREATE1(CCB,KEYBUF1,COUNT)
      IF(CMDNBR.EQ.6)     CALL CLOSARE1(CCB,KEYBUF1(2),1)
      LOCK=0
      J1=1
      DO 800 L=1,SUBNBR
 800  IF(SEG(J-1).EQ.SUBAREAS(L*2-1)) AREANO=SUBAREAS(L*2)
      IF(AREANO.GT.31) J1=2; AREANO=AREANO-32
      CALL IBS(AREAOPEN(J1),AREANO,1,MODE)
      CALL IBS(OPENMODE(J1),AREANO,1,UPDATE)
 201  CONTINUE
      IF(CMDNBR.NE.6) CALL MES
     1('   AREAS OPENED.',16); RETURN
       CALL MES('   AREAS CLOSED.',16)
       IF(AREAOPEN(1).EQ.0 .AND.AREAOPEN(2).EQ.0) STATUS=0
      RETURN
 500  CONTINUE
      CALL MES('***BAD QUERY SCHEMA FILE',24); RETURN
      END
