*     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
      INCLUDE ERSP_IN01
      INCLUDE ERSP_IN02
      INCLUDE ERSP_IN03
      WRITE (108,5)
5     FORMAT (' ERSP_1 A00 HERE')
      $PASSNMB=0
      $ALIASNM=0
      CSGPIN=1
      SCSGP=2
      TCSGP=3
      RSPROG=4
      INTEGER ZERO/0/
1     FORMAT(A1)
      WRITE(NEXTKEY,1)ZERO
      WRITE(NEXTRSP,1)ZERO
      WRITE(NEXTVK,1)ZERO
      AREACNT=0
      GRPCNT=0
      SETCNT=0
      CALL RSPINIT
      TCSGP=13
      RSPROG=14
      CALL RSLUSR
      TCSGP=23
      RSPROG=24
      CALL FXRSPI
      TCSGP=33
      RSPROG=34
      VFKS=5
      VFKT=6
      CALL GENVFK
      TCSGP=43
      RSPROG=44
      CALL GENSRT
 x8
      TCSGP=53
      RSPROG=54
      CALL FXRSPC
      TCSGP=63
      CALL GENCSF
10    STOP 'ERSP_1 FINISHED'
      END
      SUBROUTINE FXRSPI
*******        1979 07 23/CHS
**  USES CSGP INVERT ITEM INFORMATION TO FIND AND UPDATE
**  RSP ITEM DEFINITION RECORDS
*
************************************************************************
      INCLUDE ERSP_IN02
      INCLUDE ERSP_IN01
************************************************************************
*
**  STORAGE USED TO REMEMBER UPDATE INFORMATION FROM THE CSGP FILE
*
************************************************************************
     @ NAMEA1,INDIC
      EQUIVALENCE
     .(TEMPBUF(1),TEMPARA),
     .(TEMPBUF(2),TEMPGRP),
     .(TEMPBUF(3),TEMPPMN),
     .(TEMPBUF(4),TEMPPMX),
     .(TEMPBUF(5),TEMPPRM),
     .(TEMPBUF(6),NAMESIZ),
     .(TEMPBUF(7),NAMEA1)
************************************************************************
*
**  OPENS THE FILES:
**        UPDATE INFO SUPPLIED BY KEYED TARGET CSGP FILE(TCSGP)
**        RSP RECORDS UPDATED IN RSP FILE(RSPROG)
*
      OPEN(TCSGP,STATUS='OLD',ACCESS='KEYED',FORM='FORMATTED',
     @     RECL=1200,ERR=100,KEYM=16,USAGE='UPDATE')
      OPEN(RSPROG,STATUS='UNKNOWN',ACCESS='KEYED',FORM='FORMATTED',
     @     RECL=320,ERR=200,KEYM=16,USAGE='UPDATE')
5     CONTINUE
********
*
**  SEQUENTIAL READ ON KEYED TARGET CSGP FILE
*
********
      CALL RDSQBUFF(NEXTKEY,999S)
********
*
**  SELECTS INVERT ITEM RECORD
**  REMEMBERS POSITION IN TCSGP FILE USING -TEMPKEY-
**  ASSIGNS UPDATE INFORMATION TO TEMP STORAGE
*
********
      IF($CODE.NE.GRCODE.OR.$SBCOD.NE.IVCODE)GO TO 5
      CALL MAKEKEY(3,$SGRP,7,$IVGRP,TEMPKEY)
      TEMPARA=$AREA
      TEMPGRP=$IVGRP
      TEMPPMN=$IIPGMIN
      TEMPPMX=$IIPGMAX
      TEMPPRM=$PGPRI
      NAMESIZ=$IINSIZE
      CALL MOVE(NAMEA1,$IINAME,$IINSIZE)
********
*
 E
**  -CONSTRUCTS GROUP KEY USING INVERT ITEM INFO
**  -USES KEYED READ TO REPOSITION  AT GROUP RECORD WITHIN THE TCSGP FILE
*
********
      CALL MAKEKEY(3,$SGRP,1,0,CSGPKEY)
      CALL RDTCBUFF(CSGPKEY,300S)
15    CONTINUE
********
*
**  -FROM THIS GROUP POSITION THE RECORDS ARE READ SEQUENTIALLY UNTIL
**   A (2 30) ITEM DEFINITION IS FOUND WHICH CORRES. TO INVRT ITM REFERENCE
*
********
      CALL RDSQBUFF(NEXTKEY,999S)
      IF($CODE.EQ.GRCODE.AND.$SBCOD.EQ.ITCODE)GO TO 20
      GO TO 15
20    CALL COMPARE(NAMESIZ,NAMEA1,$INSIZ,$INAME,INDIC)
      IF(INDIC.EQ.0.OR.$SBCOD.NE.ITCODE)GO TO 15
********
*
**  THE ITEM DEFINITION KEY IS CONSTRUCTED AND USED TO READ THE RSP
**  ITEM DEFINITION RECORD
**  UPDATE ASSIGNMENTS ARE MADE
*
********
      CALL MAKEKEY(3,TEMPGRP,1,0,RSPKEY)
      CALL RDRSP(RSPKEY,500S)
      TEMPARA=GTGARA
      CALL RSPDEL(RSPKEY,600S)
      CALL CSGPDEL(RSPKEY,550S)
      CALL RDRSPSEQ(NEXTRSP,29S)
      INQUIRE(RSPROG,KEY=RSPKEY)
29    CALL MAKEKEY(3,$GRNUM,5,$FINC,CSGPKEY)
      CALL RDRSP(CSGPKEY,500S)
      INVERT = 1
      ITGARA=TEMPARA
      INVGRP=TEMPGRP
      INGPMN=TEMPPMN
      INGPMX=TEMPPMX
      INGPRV=TEMPPRM
      INGSIZ=((8+ITGSIZ+$TSPSIZ+3)/4)
********
*
**  UPDATED RSP ITEM DEF RECORD IS WRITTEN
**  ORIGIONAL POSITION IN TCSGP FILE IS FOUND USING KEYED READ -TEMPKEY-
**  SEQUENTIAL PROCESSING OF FILE IS CONTINUED
*
**
************************************************************************
      CALL RDRSP(CSGPKEY,600S)
      CALL MAKEKEY(3,TEMPGRP,4,0,CSGPKEY )
      CALL CSGPDEL(CSGPKEY,600S)
      CALL RDRSP(RSPKEY,35S)
30    IF(TEMPGRP.NE.ITGGRP)GO TO 35
      INQUIRE(RSPROG,KEY=RSPKEY)
      CALL RSPDEL(RSPKEY,600S)
      CALL CSGPDEL(RSPKEY,600S)
      CALL RDRSPSEQ(NEXTRSP,35S)
      GO TO 30
35    CALL RDTCBUFF(TEMPKEY,700S)
*     INSERT THE CORRECT AREA FOR THE INVERT GROUP RECORD
      $AREA=TEMPARA
      GO TO 5
100   STOP 'UNABLE TO OPEN KEYED TCSGP FILE FOR PROCESSING BY -FXRSPI'
200   STOP 'UNABLE TO OPEN KEYED RSP FILE FOR PROCESSING BY -FXRSPI'
300   STOP 'UNABLE TO DO KEYED READ ON KEYED TARGET CSGP FILE -FXRSPI '
500   STOP 'UNABLE TO READ KEYED RSP F0LE -FXRSPI  '
550   STOP 'UNABLE TO WRITE KEYED TCSGP FILE -FXRSPI- '
600   STOP 'UNABLE TO WRITE UPDATE TO KEYED RSP FILE -FXRSPI  '
700   STOP 'UNABLE TO RETURN TO LAST TCSGP REC READ SEQ"TIALLY -FXRSPI'
800   STOP 'UNABLE TO CLOSE TARGET CSGP FILE  -FXRSPI'
900   STOP 'UNABLE TO CLOSE RSP FILE -FXRSPI-'
999   CLOSE(TCSGP,STATUS='KEEP',ERR=800)
      CLOSE(RSPROG,STATUS='KEEP',ERR=900)
      RETURN
      END
      SUBROUTINE GENVFK
**  THIS SUBROUTINE GENERATES VERIFICATION KEYS FOR SOURCE AND
**  TARGET DATA BASES....THE KEYS ARE SELECTED FROM RECORDS WHICH
**  ARE THE SAME IN BOTH SOURCE AND TARGET DATABASE
**   A FIELD(ITEM) IS SELECTED BY FIRST EXAMINING THE CONTROL
**  ITEMS....THE FIRST UNMODIFIED CALC ITEM IS SELECTED
**   IF NONE THEN THE FIRST SORT ITEM....
**   IF NO CONTROL ITEM THEN FIRST INVERT ITEM....
**   OTHERWISE FIRST ITEM
**   IF NO ITEMS, BUT THERE ARE SETS A KEY OF LENGTH AND POSITION
**  ZERO(0) IS GENERATED
**
*
*
*****************************
*
**  SKPGRP - NONZERO VALUE IMPLIES....SKIP THAT GROUP
**                                IGNORE ALL RSPRECS
**  KEYFND - CONTAINS THE FINC FOR THE KEY....0 IF NONE YET FOUND
**  TESTKEY- A TEMP VERSION OF KEYFND USED TO REMEMBER THE FINC OF
**           THE FIRST UNMODIFIED ITEM WHEN LOOKING FOR AN INVERT ITEM
**
*
************************************************************************
      INCLUDE ERSP_IN01
      INCLUDE ERSP_IN03
      INTEGER SKPGRP,KEYFND,TESTKEY
**********************************
*
**  OPEN RSPROG FOR UPDATE,TCSGP FOR INPUT; VFKS,VFKT FOR OUTPUT
*
**********************************
      CALL OPENING(RSPROG,TCSGP,VFKS,VFKT)
**********************************
*
**  PROCESS USER SPECIFIED VERIFY KEY ITEMS
**  IF A USER SPECIFIED KEY IS INDICATED THE RSPRECORD
**  WILL BE UPDATED TO SET $MOD NONZERO SO THAT THE AUTOMATIC
**  KEY SELECTION WILL BE BYPASSED
*
************************************************************************
      CALL VFKUSR
      CALL RDRSPSEQ(NEXTRSP,999S)
5     CONTINUE
      GO TO(10,20,30,40,50)RSPCODE
      STOP 'INVALID RSPCODE -GENVFK-'
*****************
*
**  PROCESSES AN AREA RECORD (1,0)
*
*****************
10    VKARNO=ASCNUM
      VKCODE=1
      VKARPS=ASCSIZ
      VKBPLN=ASCLSZ
      VKCKFL=ASCCHK
      CALL VKMKKEY(VKCODE,VKARNO,0,VKKEY)
      CALL WDVFKS(VKKEY)
      VKARNO=ATGNUM
      VKCODE=1
      VKARPS=ASCSIZ
      VKBPLN=ASCLSZ
      VKCKFL=ATGCHK
      CALL VKMKKEY(VKCODE,VKARNO,0,VKKEY)
      CALL WDVFKT(VKKEY)
      GO TO 75
*****************
*
**  PROCESES A GROUP RECORD (2,GSCNUM)
*
*****************
20    SKPGRP=0
      KEYFND=0
      TESTKEY=0
      IF($MODGRP.NE.0)SKPGRP=GTGNUM
      IF(SKPGRP.NE.0)GO TO 75
      CALL MAKEKEY(3,GSCNUM,4,0,CSGPKEY)
      CALL RDTCTEMP(CSGPKEY,600S)
*
**  IF CONTREC IS EQUAL TO ZERO....THERE ARE NO CONTROL ITEMS
*
      IF(CONTREC(5).EQ.0)GO TO 29
      IF(CONTREC(INDEX).EQ.0)GO TO 28
      IF(CONTREC(INDEX).EQ.2)KEYFND=CONTREC(INDEX+1);GO TO 29
      IF(KEYFND.EQ.0)KEYFND=CONTREC(INDEX)
28    CONTINUE
29    IF(KEYFND.EQ.0)GO TO 75
      CALL MAKEKEY(3,GSCNUM,5,KEYFND,RSPKEY)
      CALL RDRSP(RSPKEY,100S)
      GO TO 70
******************
*
**  PROCESSES AN ITEM RECORD (3,ISCGRP)
*
******************
30    IF(SKPGRP.NE.0.OR.$MODITM.NE.0.OR.KEYFND.NE.0)GO TO 75
      IF(TESTKEY.EQ.0)TESTKEY=ITGPOS;
     :       INQUIRE(RSPROG,KEY=TEMPKEY);GO  TO 75
      IF(INVERT.NE.0)KEYFND=ITGPOS;
     :       INQUIRE(RSPROG,KEY=TEMPKEY);GO TO 70
      GO TO 75
******************
*
**  PROCESSES A POINTER RECORD (4,PSCGNM)
*
******************
40    IF(SKPGRP.NE.0)GO TO 75
      IF(KEYFND.NE.0)GO TO 45
      IF(TESTKEY.EQ.0)GO TO 43
*
**  RETRIEVES THE FIRST ITEM
*
      CALL MAKEKEY(3,PSCGNM,5,TESTKEY,RSPKEY)
      CALL RDRSP(RSPKEY,100S)
      KEYFND=TESTKEY
      GO TO 70
*
**  OUTPUT NULL KEY
*
43    VKCODE=3
      VKKP=0
      VKKS=0
      VKGRNO=PTGGNM
      CALL VKMKKEY(VKCODE,VKARNO,0,VKKEY)
      CALL WDVFKT(VKKEY)
      VKGRNO=PSCGNM
      CALL VKMKKEY(VKCODE,VKGRNO,0,VKKEY)
      CALL WDVFKS(VKKEY)
      KEYFND=1
45    IF($MODSET.NE.0)GO TO 75
      VKCODE=2
      VKGRNO=PSCGNM
      VKSTNO=PSETNM
      VKNPP=PSCNPOS
      VKKS=PSCNSIZ
      INQUIRE(RSPROG,KEY=CSGPKEY)
      CALL RDTCTEMP(CSGPKEY,600S)
      VKMFL=$MANUL
      CALL VKMKKEY(VKCODE,VKGRNO,VKSTNO,VKKEY)
      CALL WDVFKS(VKKEY)
      VKGRNO=PTGGNM
      VKNPS=PTGNSIZ
      CALL VKMKKEY(VKCODE,VKGRNO,VKSTNO,VKKEY)
      CALL WDVFKT(VKKEY)
      GO TO 75
***********************
*
**  PROCESSES A POTENTIAL SORT CONTROL ITEM (5,?)
*
***********************
50    CONTINUE
      GO TO 75
70    VKCODE=3
      VKGRNO=ISCGRP
      VKKP=ISCPOS
      VKKS=MIN(ISCSIZ,8)
      CALL VKMKKEY(VKCODE,VKGRNO,0,VKKEY)
      CALL WDVFKS(VKKEY)
      VKGRNO=ITGGRP
      VKKP=ITGPOS
      VKKS=MIN(ITGSIZ,8)
      CALL VKMKKEY(VKCODE,VKGRNO,0,VKKEY)
      CALL WDVFKT(VKKEY)
75    CALL RDRSPSEQ(NEXTRSP,999S)
      GO TO 5
999   CLOSE(RSPROG,STATUS='KEEP',ERR=200)
      CLOSE(TCSGP,STATUS='KEEP',ERR=300)
      CLOSE(VFKS,STATUS='KEEP',ERR=400)
      CLOSE(VFKT,STATUS='KEEP',ERR=500)
      RETURN
100   STOP 'UNABLE TO DO KEYED READ FROM KEYED RSPFILE -GENVFK-'
200   STOP 'UNABLE TO CLOSE RSP FILE  -GENVFK-'
300   STOP 'UNABLE TO CLOSE TARGET CSGP FILE  -GENVFK-'
400   STOP 'UNABLE TO CLOSE SOURCE VFK FILE  -GENVFK-'
500   STOP 'UNABLE TO CLOSE TARGET VFK FILE  -GENVFK-'
600   STOP 'UNABLE TO DO KEYED READ FROM TCSGPFILE -GENVFK-'
      END
      SUBROUTINE OPENING(RSPROG,TCSGP,VFKS,VFKT)
**  OPENS RSPROG FOR UPDATE
**         TCSGP FOR INPUT
**          VFKS FOR OUTPUT
**          VFKT FOR OUTPUT
**  UNIT ASSIGNMENTS:
**           3 - TCSGP
**           4 - RSPROG
**           5 - VFKS
**           6 - VFKT
*
************************************************************************
      INTEGER RSPROG,TCSGP,VFKS,VFKT
      OPEN(RSPROG,STATUS='OLD',ACCESS='KEYED',FORM='FORMATTED',
     .RECL=320,ERR=100,KEYM=16,USAGE='UPDATE')
      OPEN(TCSGP,STATUS='OLD',ACCESS='KEYED',FORM='FORMATTED',
     .RECL=1200,ERR=200,KEYM=16,USAGE='INPUT')
      OPEN(VFKS,STATUS='UNKNOWN',ACCESS='KEYED',FORM='FORMATTED',
     .RECL=24,ERR=300,KEYM=14,USAGE='OUTPUT')
      OPEN(VFKT,STATUS='UNKNOWN',ACCESS='KEYED',FORM='FORMATTED',
     .RECL=24,ERR=400,KEYM=14,USAGE='OUTPUT')
      RETURN
100   STOP 'UNABLE TO OPEN RSP FILE FOR UPDATE -GENVFK--OPENING'
200   STOP 'UNABLE TO OPEN TARGET CSGP FILE FOR INPUT  -GENVFK--OPENING'
300   STOP 'UNABLE TO OPEN SOURCE VFK FILE FOR OUTPUT -GENVFK--OPENING'
400   STOP 'UNABLE TO OPEN TARGET VFK FILE FOR OUTPUT -GENVFK--OPENING'
      END
      SUBROUTINE WDVFKS(VKKEY)
**  WRITES ONE RECORD TO KEYED SOURCE VFK FILE
*
************************************************************************
      INCLUDE ERSP_IN03
      WRITE(VFKS,'(6A4)',KEY=VKKEY,ERR=100)VKBUF
      RETURN
100   STOP 'UNABLE TO WRITE TO KEYED SOURCE VFK FILE -GENVFK--WDVFKS-'
      END
      SUBROUTINE WDVFKT(VKKEY)
**  WRITES ONE  RECORD TO KEYED TARGET VFK FILE
*
************************************************************************
      INCLUDE ERSP_IN03
      WRITE(VFKT,'(6A4)',KEY=VKKEY,ERR=100)VKBUF
      RETURN
100   STOP 'UNABLE TO WRITE TO KEYED TARGET VFK FILE -GENVFK--WDVFKT-'
      END
      SUBROUTINE FXRSPC
**  PROCESSES RSP FILE--
**                      FOR EACH CALC CNTRL ITEM A NEW KEY IS GENERATED
**                      AND THE RECORD IS RE-WRITTEN. PREVIOUS RECORD &
**                      KEY ARE DELETED. -- CHANGES ORDER OF RECORDS
**                      FOR SEQUENTIAL PROCESSING.
*
*
************************************************************************
      INCLUDE ERSP_IN02
      INTEGER TBL(30),TBLNM
      OPEN(RSPROG,STATUS='OLD',ACCESS='KEYED',FORM='FORMATTED',
     @     RECL=320,ERR=100,KEYM=16,USAGE='UPDATE')
      OPEN(TCSGP,STATUS='OLD',ACCESS='KEYED',FORM='FORMATTED',
     @     RECL=1200,ERR=200,KEYM=16,USAGE='INPUT')
5     CONTINUE
      CALL RDSQBUFF(NEXTKEY,999S)
      IF($CODE.NE.GRCODE.OR.$SBCOD.NE.CICODE)GO TO 5
      TBLNM=0
      IF(BUFFER(5).EQ.0)GOTO 5
      DO 6 INDEX=1,30
      TBL(INDEX)=0
6     CONTINUE
      DO 10 INDEX=6,((BUFFER(5)-1)*4+6),4
      IF(BUFFER(INDEX).NE.2)GO   TO 10
      TBL(BUFFER(INDEX+2))=BUFFER(INDEX+1)
      TBLNM=TBLNM+1
10    CONTINUE
      IF(TBLNM.EQ.0)GO TO 5
      DO 20 INDEX=1,TBLNM
      IF(TBL(INDEX).EQ.0)GO TO 20
      CALL MAKEKEY(3,$GRNUM,5,TBL(INDEX),RSPKEY)
      CALL RDRSP(RSPKEY,300S)
      CALL RSPDEL(RSPKEY,700S)
      CALL MAKEKEY(3,$GRNUM,4,INDEX,RSPKEY)
      CALL WDRSP(RSPKEY,400S)
20    CONTINUE
      GO TO 5
100   STOP 'UNABLE TO OPEN KEYED RSP FILE FOR PROCESSING BY -FXRSPC-'
200   STOP 'UNABLE TO OPEN KEYED TARGET CSGP FILE -FXRSPC-'
300   STOP 'UNABLE TO READ FROM KEYED RSP FILE -FXRSPC-'
400   STOP 'UNABLE TO WRITE TO KEYED RSP FILE -FXRSPC-'
500   STOP 'UNABLE TO CLOSE RSP FILE  -FXRSPC-'
600   STOP 'UNABLE TO CLOSE TCSGP FILE  -FXRSPC-'
700   STOP 'UNABLE TO DELETE KEYED RECORD FROM RSP FILE  -FXRSPC-'
999   CLOSE(RSPROG,STATUS='KEEP',ERR=500)
      CLOSE(TCSGP,STATUS='KEEP',ERR=600)
      RETURN
      END
      SUBROUTINE GENCSF
**  DELETES SET OWNER AND MEMBER DEFINITION RECORDS FROM
**  GROUP MEMBERSHIP IN THE KEYED TARGET CSGP FILE
**                 I.E.  KEY    3 , GRP# , 6 , SETNO#
*
*
*
************************************************************************
      INCLUDE ERSP_IN01
      OPEN(TCSGP,STATUS='OLD',ACCESS='KEYED',FORM='FORMATTED',
     @     RECL=1200,ERR=100,KEYM=16,USAGE='UPDATE')
5     CONTINUE
      CALL RDSQBUFF(NEXTKEY,999S)
      IF($CODE.EQ.STCODE.AND.($SBCOD.EQ.0.OR.$SBCOD.EQ.MMCODE)) GO TO 9
      GO TO 5
9     INQUIRE(TCSGP,EXIST=XIST,OPENED=OPND,NAMED=NMD,KEY=CSGPKEY)
      IF(XIST.AND.OPND.AND.NMD)GO TO 10
      OUTPUT '-GENCSF-'
      STOP 'LOGICAL UNIT UNASSIGNED, UNCONNECTED OR FILE UNNAMED'
10    IF(CSGPKEY(11:12).NE.' 6')GO TO 5
      CALL CSGPDEL(CSGPKEY,400S)
      GO TO 5
100   STOP 'UNABLE TO OPEN TARGET CSGP FILE FOR INPUT  -GENCSF-'
200   STOP 'UNABLE TO CLOSE TARGET CSGP FILE  -GENCSF-'
400   STOP 'UNABLE TO DELETE TCSGP KEYED RECORD  -GENCSF-'
999   CLOSE(TCSGP,STATUS='KEEP',ERR=200)
      RETURN
      END
      SUBROUTINE MOVE(NAME1,NAME2,SIZE)
      INTEGER NAME1(1),NAME2(1),SIZE,INDEX
      DO 5 INDEX=1,SIZE
      NAME1(INDEX)=NAME2(INDEX)
5     CONTINUE
99    RETURN
      END
      SUBROUTINE MAKEKEY($TRECTYP,$TGROUP,$TDISPL,
     @                $TIDENT,CSGPKEY)
**  CREATES THE CHARACTER KEY USED FOR WRITTING THE KEYED
**  CSGP AND RSP FILES --- IT COMBINES 4 INTEGER VARIABLES
**                           INTO 1 CHARACTER VARIABLE USING THE
**                         ENCODE AND DECODE OPERATORS
*
************************************************************************
      INCLUDE ERSP_IN01
      INTEGER $TRECTYP,$TGROUP,$TDISPL,$TIDENT,TMPKEY(4)
      ENCODE(16,2000,TMPKEY)$TRECTYP,$TGROUP,$TDISPL,$TIDENT
2000  FORMAT(I2,I8,I2,A4)
      DECODE(16,'(A16)',TMPKEY)CSGPKEY
      END
      SUBROUTINE VKMKKEY(PART1,PART2,PART3,VKKEY)
**  CREATES THE CHARACTER KEY USED FOR WRITTING THE VFK FILES....
**     IT COMBINES 3 INTEGER VARIABLES INTO 1 CHARACTER VARIABLE
**     USING THE ENCODE AND DECODE OPERATORS
*
************************************************************************
      INCLUDE ERSP_IN03
      INTEGER PART1,PART2,PART3,TEMPKEY(4)
      ENCODE(14,1000,TEMPKEY)PART1,PART2,PART3
1000  FORMAT(I2,I4,I8)
      DECODE(14,'(A14)',TEMPKEY)VKKEY
      RETURN
      END
      SUBROUTINE COMPARE(NAMESIZ,NAMEA1,COMPNSIZ,COMPNAME,INDIC)
**  COMPARES NAMES STORED IN A1 FORMAT
**  PASSES 1 IF IDENTICAL-- 0 IF NO MATCH
*
************************************************************************
      INTEGER NAMESIZ,NAMEA1(1),COMPNSIZ,COMPNAME(1),INDIC,INDEX
      CHARACTER*31 K1,K2
      INDIC=1
10    WRITE(K1,'(31A1)'),(NAMEA1(INDEX),INDEX=1,NAMESIZ)
      WRITE(K2,'(31A1)'),(COMPNAME(INDEX),INDEX=1,COMPNSIZ)
      IF(K1.EQ.K2)GO TO 99
      INDIC=0
99    RETURN
      END
      FUNCTION GPRIME(LOWPG,HIPG)
      INTEGER LOWPG,HIPG,GPRIME,N,I,K
      N=HIPG-LOWPG+1
      K=N
10    IF(K.EQ.2)GO TO 30
      IF(MOD(K,2).EQ.0)K=K+1
      IF(K.EQ.3)GO TO 30
      IF(K.EQ.5)GO TO 30
      DO 20 I=3,(K-1)/2,2
      IF(MOD(K,I).EQ.0) GO TO 25
20    CONTINUE
       GO TO 30
25    K=K+1
      GO TO 10
30    GPRIME=K
      RETURN
      END
      SUBROUTINE RSPINIT
****:      1979 07            24/CHS
**  TAKES THE SEQUENTIAL CSGP FILE AND CONSTRUCTS KEYS FOR KEYED
**  SOURCE AND TARGET CSGP FILES WHICH IT GENERATES
**
*
*
************************************************************************
***** DOCUMENTATION **************** AS OF 1979 07 19/CHS
************************************************************************
*
*         KEY                      RECORD DEFINITION       CODE SBCODE
*        -----                    -------------------     -------------
*======================================================================
*   2 , $AREA    , 1  , 0              AREA                 ( 1, 0)
*   3 , $GRPNM   , 1  , 0              GROUP                ( 2, 0)
*   3 , $SGRPNM  , 2  , 0              VIA SET              ( 2,10)
*   3 , $SGRPNM  , 3  , 0              STORAGE SET          ( 2,11)
*   3 , $GRNUM   , 4  , 0              CONTROL ITEM         ( 2,25)
*   3 , $GRNUM   , 5  , $FINC          ITEM DEFINITION      ( 2,30)
*   3 , $SGRP    , 7  , $IVGRP         INVERT ITEM          ( 2,40)
*   4 , $SETN    , 1  , 0              OWNER(SET)           ( 3, 0)
*   3 , $OGRP    , 6  , $SETN             "                     "
*   4 , $MSETN   , 2  , $MGRPNM        MEMBER               ( 3,10)
*   3 , $MGRPNM  , 6  , $MSETN            "                     "
*   4 , $MSETN   , 3  , $ALIASNM       ALIAS                ( 3,20)
*   1 , 1        , 0  , 0              SUBSCHEMA            ( 7, 0)
*   1 , 0        , 0  , 0              SCHEMA NAME       RSPINIT GENERATED
*   1 , 2  , $PASSNMB , 0              P ASSWORD            ( 8, 0)
*   2 , $AREA    , 2  , 0              INDEX-SEQUENTIAL    (10,0)
************************************************************************
      INTEGER STRT,FINI,ICALC,GPRIME
************************************************************************
**  INCLUDE FILE CONTAINING CSGP FILE RECORD EQUIVALENCES
************************************************************************
**  INCLUDE FILE CONTAINING RSP FILE RECORD EQUIVALENCES
      INCLUDE ERSP_IN02
************************************************************************
      CALL OPNING(CSGPIN,SCSGP,TCSGP,RSPROG)
************************************************************************
**  OPENS THE FILES FOR PROCESSING
************************************************************************
      CALL RSPSIZ
************************************************************************
**  RETRIEVES POINTER SIZE PARAMETER FROM SUBSCHEMA DEF'N
5     CONTINUE
************************************************************************
**  REPEATING CODE SECTION
************************************************************************
      CALL RDCSGP
************************************************************************
**  END-OF-FILE TEST
************************************************************************
      GO TO (10,20)            ($STATS-1)
************************************************************************
*
**  TESTS FOR CODE VALIDITY AND BRANCHES ACCORDINGLY
*
************************************************************************
10            GO TO (30,40,50) $CODE
      IF($CODE.EQ.SBCODE.AND.$SBCOD.EQ.0)            GO TO 60
      IF($CODE.EQ.PSCODE.AND.$SBCOD.EQ.0)            GO TO 70
      IF($CODE.EQ.ISCODE.AND.$SBCOD.EQ.0)            GO TO 80
      STOP 'ERROR--NONEXISTENT CODE FOUND FOR CSGP FILE RECORD--RSPINIT'
20            CLOSE(CSGPIN,STATUS='KEEP',ERR=400)
              CLOSE(TCSGP,STATUS='KEEP',ERR=600)
              CLOSE(RSPROG,STATUS='KEEP',ERR=700)
              RETURN
*
**  TESTS FOR SUBCODE VALIDITY AND BRANCHES ACCORDINGLY
*
************************************************************************
30            IF($SBCOD.EQ.0)GO TO 90
      STOP 'ERROR--INVALID SUBCODE FOR AREA DEFINITION-RSPINIT-'
40            IF($SBCOD.EQ.0)GO TO 100
      IF($SBCOD.EQ.VSCODE)GO TO 110
      IF($SBCOD.EQ.(VSCODE+1))GO TO 111
      IF($SBCOD.EQ.CICODE)GO TO 119
      IF($SBCOD.EQ.ITCODE)GO TO 120
      IF($SBCOD.EQ.IVCODE)GO  TO 130
      STOP 'ERROR--INVALID SUBCODE FOR GROUP DEFINITION -RSPINIT-'
50            IF($SBCOD.EQ.0)GO TO 140
      IF($SBCOD.EQ.MMCODE)GO TO 150
      IF($SBCOD.EQ.ALCODE)GO TO 160
      STOP 'ERROR--INVALID SUBCODE FOR SET DEFINITION -RSPINIT-'
************************************************************************
*
**  PROCESSES A SUBSCHEMA DEFINITION RECORD (7,0)
*
************************************************************************
60    CALL MAKEKEY(1,1,0,0,CSGPKEY)
      CALL WDCSGP(CSGPKEY)
************************************************************************
*
**  PROMPTS FOR AND CREATES A SCHEMA RECORD CONTAINING SCHEMA NAME
*
************************************************************************
      OUTPUT 'ENTER THE SCHEMA NAME'
      INTEGER IBLANK/4H    /
      READ(105,1000),(BUFFER(INDEX),INDEX=2,32)
      WRITE(108,1000),(BUFFER(INDEX),INDEX=2,32)
      BUFFER(1)=0
      DO 1013 INDEX = 2,32
      IF(BUFFER(INDEX).EQ.IBLANK)GO TO 1014
1013  BUFFER(1)=BUFFER(1)+1
1014  CONTINUE
1000  FORMAT(31A1)
      CALL MAKEKEY(1,0,0,0,CSGPKEY)
      CALL WDCSGP(CSGPKEY,300S)
      GO TO 5
************************************************************************
*
**  PROCESSES A PASSWORD DEFINITION RECORD (8,0)
*
************************************************************************
70    CALL MAKEKEY(1,2,$PASSNMB,0,CSGPKEY)
      CALL WDCSGP(CSGPKEY,300S)
      $PASSNMB=$PASSNMB+1
      GO TO 5
************************************************************************
*
**  PROCESSES AN INDEX-SEQUENTIAL DEFINITION RECORD (10,0)
*
************************************************************************
80    GO TO 5
************************************************************************
*
** PROCESSES AN AREA DEFINITION RECORD (1,0)
*
************************************************************************
90    CALL MAKEKEY(2,$AREA,1,0,CSGPKEY)
      $FLPCT=0
      $IKSIZ=0
      $OVMIN=-1
      $OVMAX=-1
      CALL WDCSGP(CSGPKEY,300S)
      RSPCODE=1
      RSPSORT=0
      ASCNUM=$AREA
      ATGNUM=$AREA
      ASCSIZ=$NPAGE
      ATGSIZ=$NPAGE
      ASCLSZ=$DPLNN
      ATGLSZ=$DPLNN
      ASCCHK=$CHKSM
      ATGCHK=$CHKSM
      ATGFIL=$FLPCT
      ATGINV=$INVPC
********************
*
**  STORES AREA NAME IN AN ARRAY
*
********************
      AREACNT=AREACNT+1
      WRITE(AREANMS(AREACNT),'(31A1)'),(BUFFER(INDEX),INDEX=18,
     @17+$NMCNT)
      ARANUM(AREACNT)=$AREA
      ENCODE (32,31,RSPNAM)      AREANMS(AREACNT)
31    FORMAT(A31)
      CALL WDRSP(CSGPKEY,300S)
      GO TO 5
************************************************************************
*
**  PROCESSES A GROUP DEFINITION RECORD (2,0)
*
************************************************************************
100   $ALIASNM=0
      CALL MAKEKEY(3,$GRPNM,1,0,CSGPKEY)
      IF($GRTYP.EQ.3)$GRTYP=2;$PGPRM=GPRIME($GPGMIN,$GPGMAX)
      CALL WDCSGP(CSGPKEY,300S)
      RSPCODE=2
      RSPSORT=$GRPNM
      GSCARA=$AREA
      GTGARA=$AREA
      GSCNUM=$GRPNM
      GTGNUM=$GRPNM
      IF($GRPNM.GE.1000)GTGNUM=GSCNUM-100
      GSCPMN=$GPGMIN
      GTGPMN=$GPGMIN
      GSCPMX=$GPGMAX
      GTGPMX=$GPGMAX
      GTGPRV=$PGPRM
      GTGSIZ=$DBGSZ
      GTGLCM=$GRTYP
      GFLPCT=80
      $MODGRP=0
*     DON'T GENERATE VERIFY KEYS FOR SET-LESS GROUPS!!!
************************
*
**  STORES THE GROUP NAME AND NUMBER IN
**  CORRESPONDING ARRAYS...ALLOWS FOR QUICK NAME SEARCH AND
**  DIRECT ACCESS TO KEYED FILES USING GRP NUM TO CONSTRUCT KEY
*
************************
      GRPCNT=GRPCNT+1
      WRITE(GRPNMS(GRPCNT),'(31A1)'),(BUFFER(INDEX),INDEX=21,20+$NSIZE)
*  KEY CONSTRUCTION REFERENCE TABLE
      IF(GRPNMS(GRPCNT).EQ.BLANK)
     . GRPNMS(GRPCNT)='%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%'
      GRPNUM(GRPCNT)=$GRPNM
      ENCODE(32,31,RSPNAM) GRPNMS(GRPCNT)
      CALL WDRSP(CSGPKEY)
      GO TO 5
************************************************************************
*
**  PROCESSES A VIA SET DEFINITION RECORD (2,10)
*
************************************************************************
110   CALL MAKEKEY(3,$SGRPNM,2,0,CSGPKEY)
      CALL WDCSGP(CSGPKEY)
      GO TO 5
************************************************************************
*
**  PROCESSES A STORAGE SET DEFINITION RECORD (2,11)
*
************************************************************************
111   CALL MAKEKEY(3,$SGRPNM,3,0,CSGPKEY)
      GO TO 5
************************************************************************
*
**  PROCESSES A CONTROL ITEM DEFINITION RECORD (2,25)
*
************************************************************************
119   CALL MAKEKEY(3,$GRNUM,4,0,CSGPKEY)
      ICALC=0
*     SCAN THE CONTROL ITEM DEFINITION RECS(4WORDS EA) TACKED ON TO ITEM DEF.
*     IF ANY OF THE KEYS ARE INDEXED, CHANGE TO CALC IN THE DO LOOP.
      DO 125 INDEX=6,((BUFFER(5)-1)*4+6),4
      IF(BUFFER(INDEX).EQ.8)BUFFER(INDEX)=2
      IF (BUFFER(INDEX).EQ.2) ICALC=2
125   CONTINUE
      CALLWDCSGP(CSGPKEY,300S)
      IF (ICALC.NE.2) GO TO 128
*     ITEM IS A CALC KEY - RE-WRITE THE ITEM DEFINITION REC IN RSP FILE
      CALL RDRSP(ITEMKEY,800S)
      CALL RSPDEL(ITEMKEY,800S)
      ICNTRL=1
      CALL WDRSP(ITEMKEY,800S)
128   CONTINUE
      GO TO 5
************************************************************************
*
**  PROCESSES AN ITEM DEFINITION RECORD (2,30)
*
************************************************************************
120   CALL MAKEKEY(3,$GRNUM,5,$FINC,CSGPKEY)
      CALL WDCSGP(CSGPKEY,300S)
      INTEGER  $PTR,$PSIZE,$OCCURS,$SIGN,$DLEN
      RSPCODE=3
      RSPSORT=$GRNUM
      ICNTRL=0
      ISCGRP=$GRNUM
      ITGGRP=$GRNUM
      IF($GRNUM.GE.1000)ITGGRP=ISCGRP-100
      ITYPCD=$ITYPE
      INVERT=0
*     WILL BE RESET IFF REQUIRED BY FXRSPI
      ITGARA=$AREA
      INVGRP=0
      INGPMN=0
      INGPMX=0
      INGPRV=0
      INGSIZ=0
      ISCPOS=$FINC
      ITGSIZ=$ISIZE
      ISCSIZ=$ISIZE
      ITGPOS=$FINC
      IEXPND=0
      $MODITM=0
*     SAVE ITEM KEY FOR CALC CONTROL FIELD MODIFICATION BY CONTROL RECORD
      ITEMKEY=CSGPKEY
      $PTR=$INSIZ+15
      $PSIZE=BUFFER($INSIZ+14)
      CALL PICSCAN($OCCURS,$ISIZE,$ITYPE,$PSIZE,BUFFER($PTR),
     @$SIGN,$DLEN)
      IPDLEN=$DLEN
      ISIGN=$SIGN
      ENCODE (32,32,RSPNAM)      (BUFFER(INDEX),INDEX=14,13+$INSIZ)
32    FORMAT(31A1)
      CALL WDRSP(CSGPKEY,220S)
      GO TO 5
************************************************************************
*
**  PROCESSES AN INVERT ITEM DEFINITION RECORD (2,40)
*
************************************************************************
130   CALL MAKEKEY(3,$SGRP,7,$IVGRP,CSGPKEY)
      CALL WDCSGP(CSGPKEY,300S)
      GO TO 5
************************************************************************
*
**  PROCESSES AN OWNER(SET) DEFINITION RECORD (3,0)
*
************************************************************************
140   CALL MAKEKEY(4,$SETN,1,0,CSGPKEY)
      CALL WDCSGP(CSGPKEY,300S)
      RSPCODE=4
      RSPSORT=$OGRP
      PSETNM=$SETN
      PSCGNM=$OGRP
      PTGGNM=$OGRP
      IF($OGRP.GE.1000)PTGGNM=PSCGNM-100
      PSCNPOS=$SPNEXT
      PSCNSIZ=$TSPSIZ
      PTGNPOS=$SPNEXT
      PTGNSIZ=$TSPSIZ
      PSCPPOS=$SPRIOR
      PSCPSIZ=$TSPSIZ
      PTGPPOS=$SPRIOR
      PTGPSIZ=$TSPSIZ
      PSCOPOS=-1
      PSCOSIZ=$TSPSIZ
      PTGOPOS=-1
      PTGOSIZ=$TSPSIZ
      $MODSET=0
      CALL MAKEKEY(3,$OGRP,6,$SETN,CSGPKEY)
      CALL WDCSGP(CSGPKEY,300S)
****************
*
**  STORES THE SET NAME AND NUMBER IN CORRESPONDING ARRAYS
**  ALLLOWING FOR DIRECT ACCESS OF KEYED FILES BY SEARCHING
**  TABLE AND CONSTRUCTING KEY USING SET NUMBER
*
****************
      STRT=$ONSIZ+13
      FINI=$ONSIZ+12+BUFFER($ONSIZ+12)
      SETCNT=SETCNT+1
      WRITE(SETNMS(SETCNT),'(31A1)'),(BUFFER(INDEX),INDEX=STRT,FINI)
      SETNUM(SETCNT)=$SETN
      ENCODE (32,31,RSPNAM) SETNMS(SETCNT)
      CALL WDRSP(CSGPKEY,220S)
      GO TO 5
************************************************************************
*
**  PROCESSES A MEMBER DEFINITION RECORD (3,10)
*
************************************************************************
150   CALL MAKEKEY(4,$MSETN,2,$MGRPNM,CSGPKEY)
      CALL WDCSGP(CSGPKEY,300S)
      RSPCODE=4
      RSPSORT=$MGRPNM
      PSETNM=$MSETN
      PSCGNM=$MGRPNM
      PTGGNM=$MGRPNM
      IF($MGRPNM.GE.1000)PTGGNM=PSCGNM-100
      PSCNPOS=$PNEXT
      PSCNSIZ=$TSPSIZ
      PTGNPOS=$PNEXT
      PTGNSIZ=$TSPSIZ
      PSCPPOS=$PRIOR
      PTGPPOS=$PRIOR
      PTGPSIZ=$TSPSIZ
      PSCPSIZ=$TSPSIZ
      PSCOPOS=$PHEAD
      PSCOSIZ=$TSPSIZ
      PTGOPOS=$PHEAD
      PTGOSIZ=$TSPSIZ
      $MODMEM=0
      CALL MAKEKEY(3,$MGRPNM,6,$MSETN,CSGPKEY)
      CALL WDCSGP(CSGPKEY,300S)
      DO 155 INDEX=1,SETCNT
      IF($MSETN.EQ.SETNUM(INDEX))GO TO 157
155   CONTINUE
157   CONTINUE
      ENCODE (32,31,RSPNAM) SETNMS(INDEX)
      CALL WDRSP(CSGPKEY,220S)
      GO TO 5
************************************************************************
*
**  PROCESSES AN ALIAS DEFINITION RECORD (3,20)
*
************************************************************************
160   CALL MAKEKEY(4,$MSETN,3,$ALIASNM,CSGPKEY)
      CALL WDCSGP(CSGPKEY,300S)
      GO TO 5
220   STOP ' UNABLE TO WRITE KEYED RSP -RSPINIT-'
300   STOP 'UNABLE TO WRITE TO KEYED TARGET CSGP FILE -RSPINIT-'
400   STOP 'UNABLE TO CLOSE SEQUENTIAL ORIGIN CSGP FILE  -RSPINIT-'
600   STOP 'UNABLE TO CLOSE TARGET CSGP FILE  -RSPINIT-'
700   STOP 'UNABLE TO CLOSE RSP FILE  -RSPINIT-'
800   STOP 'UNABLE TO MODIFY RSP FILE FOR CALC FIELD'
      END
      SUBROUTINE OPNING(CSGPIN,SCSGP,TCSGP,RSPROG)
*
**  OPENS SEQUENTIAL SOURCE DATA BASE CSGP FILE FOR INPUT
**  SOURCE AND TARGET KEYED CSGP FILES FOR OUTPUT
**  RSP KEYED FILE FOR OUTPUT
**  UNIT NUMBER ASSIGNMENTS
**        F:1=CSGPIN
**        F:2=SCSGP
**        F:3=TCSGP
**        F:4=RSPROG
*
************************************************************************
      INTEGER CSGPIN,SCSGP,TCSGP,TRCSGP,RSPROG
      OPEN(CSGPIN,STATUS='OLD',
     @FORM='UNFORMATTED',RECL=1200,ERR=10,USAGE='INPUT')
      OPEN(TCSGP,STATUS='UNKNOWN',ACCESS='KEYED',
     @FORM='FORMATTED',RECL=1200,ERR=30,KEYM=16,USAGE='OUTPUT')
      OPEN(RSPROG,STATUS='UNKNOWN',ACCESS='KEYED',
     @FORM='FORMATTED',RECL=320,ERR=40,KEYM=16,USAGE='OUTPUT')
      RETURN
10    OUTPUT '-RSPINIT--OPNING-'
      STOP 'UNABLE TO FIND SOURCE DATA BASE CSGP FILE'
30    OUTPUT '-RSPINIT--OPNING-'
      STOP 'UNABLE TO OPEN OUTPUT FILE FOR KEYED TARGET CSGP FILE'
40    OUTPUT '-RSPINIT--OPNING-'
      STOP 'UNABLE TO OPEN OUTPUT FILE FOR KEYED RSP FILE'
      END
      SUBROUTINE RSPSIZ
**  SEARCHES THE CSGP FILE FOR THE SUBSCHEMA DEFINITION RECORD
**  AND EXTRACTS THE POINTER SIZE PARAMETER REQUIRED FOR RSP RECORDS.
*
************************************************************************
      INCLUDE ERSP_IN01
5     CONTINUE
      CALL RDCSGP
      GO TO(10,20)($STATS-1)
10    IF($CODE.EQ.SBCODE)GO TO 100
      GO TO 5
20    OUTPUT '-RSPINIT--RSPSIZ'
      STOP 'ERROR--UNABLE TO FIND SUBSCHEMA DEFINITION IN CSGP FILE'
100   $TSPSIZ=$SPSIZ
      REWIND CSGPIN
      RETURN
      END
      SUBROUTINE RDCSGP
**  READS ONE RECORD OF THE SOURCE DATA BASE CSGP FILE
*
************************************************************************
      INCLUDE ERSP_IN01
      CALL BUFFER IN(CSGPIN,0,BUFFER,300,$STATS)
      GO TO(10,20,20,30),$STATS
      OUTPUT '-RSPINIT--RDCSGP-'
      STOP 'UNKNOWN STATUS INDICATOR GENERATED FROM BUFFER IN CALL'
10    OUTPUT '-RSPINIT--RDCSGP-'
      STOP 'INCORRECT INDICATOR MESSAGE (1) GENERATED BY BUFFER IN CALL'
20    RETURN
30    OUTPUT '-RSPINIT--RDCSGP-'
      STOP 'ERROR CONDITION HAS OCCURRED DURING BUFFER IN CALL'
      END
      SUBROUTINE GENSRT
**  GENSRT GENERATES A SORT CONTROL RECORD (5,?) IN THE RSP RECORD
**
***  CONTROL ITEM RECORDS ARE FOUND BY READING TCSGP SEQUENTIALLY
***  A CONTOL RECORD IS SEARCHED UNTIL THE FIRST ALPHABETIC SORT
***  ITEM IS ENCOUNTERED....THE RECORD IS THEN SEARCHED FOR ALL OTHER
***  SORT ITEMS AFFECTING THE SAME SET....THESE ARE OUTPUT TO THE NEW
***  RSP RECORD IN THE ORDER THEY APPEAR IN THE DDL
** PROCESSING OF THE CONTROL ITEM RECORD IS CONTINUED FOR THE NEXT
** ITEMS AFFECTING A DIFFERENT SET
**** THE SET KEY IS BUILT AND INFO IS EXTRACTED FROM THE TCSGP FILE
**** TO MAKE THE RSP SORT CONTROL REC FOR EACH SET COMPLETE
*
************************************************************************
      INCLUDE ERSP_IN01
      INCLUDE ERSP_IN02
      INTEGER TEMPSET
     @     RECL=1200,ERR=100,KEYM=16,USAGE='INPUT')
      OPEN(RSPROG,STATUS='OLD',ACCESS='KEYED',FORM='FORMATTED',
     @     RECL=320,ERR=200,KEYM=16,USAGE='UPDATE')
5     CONTINUE
*
**  TCSGP IS READ SEQUENTILLY UNTIL A CONTROL ITEM IS ENCOUNTERED
**  ITS KEY IS CONSTRUCTED AND REMEMBERED AS THE STARTING PT. FOR
**  FURTHER TCSGP PROCESSING
*
      CALL RDSQTEMP(NEXTKEY,199S)
      IF(TEMPBUF(2).NE.GRCODE.OR.TEMPBUF(3).NE.CICODE)GO TO 5
      CALL MAKEKEY(3,TEMPBUF(4),4,0,TEMPKEY)
15    CONTINUE
************************************************************************
*
**  AN INNER AND OUTER DO LOOP ARE USED TO PROCESS THE CONTROL REC
***  THE OUTER LOOP FINDS THE FIRST ALPHABETIC SORT ITEM AND SELECTS
***  ITS SET FOR PROCESSING...THE INNER LOOP SELECTS ALL OTHER SORT
***  ITEMS AFFECTING THAT SET AND OUTPUTS THEM TO THE RSP REC
***  ACCORDING TO THEIR DDL ORDER
****  WHEN ALL ITEMS FOR THAT SET ARE IN THE BUFFER THE CONTROL INFO
****  AT THE BEGINNING OF THE RECORD IS FILLED IN AND THE RECORD WRIT.
****  EACH ITEM SELECTED IS TEMPORARILY ZEROED SO IT WON'T BE USED
****  AGAIN
***  THE OUTER DO IS SITTING AT THE NEXT ITEM AND WILL PICK UP THE
***  NEXT GROUP OF SET ITEMS.....ETC.
*
************************************************************************
      DO 45 INDEX=6,((TEMPBUF(5)-1)*4+6),4
      IF(.NOT.(TEMPBUF(INDEX).EQ.4.OR.TEMPBUF(INDEX).EQ.6))GO TO 45
      TEMPSET=TEMPBUF(INDEX+3)
      SRTNKS=0
25    DO 35 SRTPTRS=INDEX,((TEMPBUF(5)-1)*4+6),4
      IF(.NOT.(TEMPBUF(INDEX).EQ.4.OR.TEMPBUF(INDEX).EQ.6))GO TO 35
      CALL MAKEKEY(3,TEMPBUF(4),5,TEMPBUF(SRTPTRS+1),CSGPKEY)
      CALL RDTCBUFF(CSGPKEY,300S)
      IF(TEMPSET.NE.TEMPBUF(SRTPTRS+3))GO TO 35
      RSPREC(((TEMPBUF(SRTPTRS+2)-1)*3)+10)=TEMPBUF(SRTPTRS)
      RSPREC(((TEMPBUF(SRTPTRS+2)-1)*3)+11)=$FINC
      RSPREC(((TEMPBUF(SRTPTRS+2)-1)*3)+12)=$ISIZE
      TEMPBUF(INDEX)=0
      SRTNKS=SRTNKS+1
35    CONTINUE
      IF(SRTNKS.EQ.0)GO TO 45
      RSPCODE=5
      RSPSORT=$GRNUM
      SRTSET=TEMPSET
      SRTGRP=$GRNUM
      CALL MAKEKEY(4,TEMPSET,2,$GRNUM,CSGPKEY)
      CALL RDTCBUFF(CSGPKEY,400S)
      SRTPRIOR=$PRIOR
      SRTNEXT=$PNEXT
      SRTOWNER=$PHEAD
      SRTPTRS=$TSPSIZ
      CALL MAKEKEY(5,SRTSET,0,SRTGRP,RSPKEY)
      CALL WDRSP(RSPKEY,500S)
45    CONTINUE
      CALL RDTCTEMP(TEMPKEY,600S)
      GO TO 5
199   CLOSE(TCSGP,STATUS='KEEP',ERR=700)
      CLOSE(RSPROG,STATUS='KEEP',ERR=800)
      RETURN
100   STOP 'UNABLE TO OPEN TARGET CSGP FILE FOR INPUT --GENSRT--'
200   STOP 'UNABLE TO OPEN RSP FILE TO INSERT SORT RECORD --GENSRT--'
300   STOP 'UNABLE TO READ TARGET CSGP FILE(ITEM REC) --GENSRT--'
400   STOP 'UNABLE TO READ TARGET CSGP FILE(SET MEMBER REC) --GENSRT--'
500   STOP 'UNABLE TO WRITE SORT RECORD TO RSP FILE --GENSRT--'
600   STOP 'UNABLE TO REPOSITION AT CTRL ITEM REC VIA KEYED READ-GENSRT'
700   STOP 'UNABLE TO CLOSE TARGET CSGP FILE --GENSRT--'
800   STOP 'UNABLE TO CLOSE RSP FILE --GENSRT--'
      END
      SUBROUTINE VFKUSR
**  VFKUSR ALLOWS THE USER TO SELECT VERIFICATION KEYS OTHER THAN
**  THOSE GENERATED BY DEFAULT IN THE SUBSEQUENT GENVFK SUBROUTINE.
***  THESE MUST BE CHOSEN FROM FIELDS WHICH REMAIN UNCHANGED DURING
***  THE TRANSFER FROM SOURCE TO TARGET DATA BASES
*
* IN THE TCSGP FILE-- FROM RECORD INFORMATION IN TCSGP THE
* CORRESPONDING RSP FILE RECORDS ARE ACCESSED (USING KEYS)
*  EACH SELECTION MADE IS CHECKED FOR MODIFICATIONS AS INDICATED BY A
*  NON-ZERO MOD FLAG--ONLY UNMODIFIED FIELDS MAY BE USED IN GENERATING
*  VERIFICATION KEYS.
*   ENTRIES WHICH CANNOT BE FOUND SEND THE USER TO RE-ENTER THEM
*   HE IS PROMPTED ONLY FOR THE GROUP AND ITEM HE WISHES TO SELECT
*
***  THE USER ENDS THIS SELECTION ROUTINE BY TYPING -END-
*
************************************************************************
      INCLUDE ERSP_IN01
      INCLUDE ERSP_IN02
      INCLUDE ERSP_IN03
      INTEGER INDIC
      INTEGER TEMPGRP
      INTEGER TEST
      INTEGER N,Y
      DATA N/'N'/
      DATA Y/'Y'/
1     CONTINUE
*
**  USER PROMPTING SEQUENCE-- ENTERING -N-
**                            WILL ADVANCE TO DEFAULT VFK GENERATION
*
      GO TO 1999
C THIS PROCESS HAS BEEN ELIMINTED.
      OUTPUT 'DO YOU WISH TO SPECIFY VERIFICATION KEYS (Y/N)?'
      READ(105,111),TEST
111   FORMAT(1A1)
      IF(TEST.EQ.Y)GO   TO 2
      IF(TEST.EQ.N)GO   TO 1999
      OUTPUT 'PLEASE ANSWER BY TYPING -Y- OR -N-'
      GO TO 1
2     CONTINUE
      OUTPUT 'TO END SPECIFICATION OF VERIFICATION KEYS TYPE -END-'
5     CONTINUE
*
**  THE GROUP IS ENTERED BY THE USER AND IS PROCESSED
*
      OUTPUT 'ENTER THE GROUP NAME '
      READ(105,1000)COMPTBL
1000  FORMAT(A31)
*
**  END OF FILE CONDITION IS TESTED
*
      IF(ENDBUF.EQ.COMPTBL)GO TO 999
15    CONTINUE
************************************************************************
*
**   IF CORRESPONDING NAME IS FOUND KEY IS BUILT WHICH POSITIONS
**   TCSGP AND RSP FILES AT MATCHING GROUP RECORDS
*
************************************************************************
      DO 20 INDEX=1,(GRPCNT)
      IF(GRPNMS(INDEX).EQ.COMPTBL)$GRPNM=GRPNUM(INDEX);GO  TO 22
20    CONTINUE
      GO TO 199
22    CALL MAKEKEY(3,$GRPNM,1,0,RSPKEY)
      CALL RDTCBUFF(RSPKEY,101S)
      CALL RDRSP(RSPKEY,100S)
*
**  ACCESS CONDITION IS CHECKED--ACCESS IS ALLOWED ONLY IF ZERO
**  INDICATING NO MODIFICATIONS HAVE OCCURED
*
      IF($MODGRP.NE.0)GO TO 600
      TEMPGRP=$GRPNM
25    CONTINUE
*
**  THE ITEM IS ENTERED BY THE USER AND IS PROCESSED*
*
      OUTPUT 'ENTER THE ITEM NAME '
      READ(105,1222),(TEMPBUF(INDEX),INDEX=1,31)
1222  FORMAT(31A1)
35    CONTINUE
************************************************************************
*
**  THE TCSGP FILE IS READ SEQUENTIALLY UNTIL THE ITEM IS FOUND;
**  -ANOTHER GROUP DEF IS ENCOUNTERED;
**  -OR UNTIL END OF FILE
*
************************************************************************
      CALL RDSQBUFF(NEXTKEY,700S)
      IF($CODE.NE.GRCODE.OR.$SBCOD.NE.ITCODE)GO TO 35
      IF(TEMPGRP.NE.$GRNUM)GO TO 700
      CALL COMPARE($INSIZ,$INAME,31,TEMPBUF,INDIC)
************************************************************************
*
**  WHEN THE ITEM IS FOUND THE GROUP NUM AND FILE INCR ARE USED TO BUILD
**  THE KEY TO ACCESS THE CORRESPONDING RSP RECORD
**   IF MODIFICATIONS HAVE NOT OCCURRED(MODITM=0) VFK RECORDS ARE GENR'T
**
************************************************************************
      IF(INDIC.EQ.0)GO TO 35
      TEMPKEY=RSPKEY
      INQUIRE(TCSGP,KEY=RSPKEY)
      CALL RDRSP(RSPKEY,200S)
      IF($MODITM.NE.0)GO TO 800
      VKCODE=3
      VKGRNO=ISCGRP
      VKKP=ISCPOS
      VKKS=ISCSIZ
      CALL VKMKKEY(VKCODE,VKGRNO,0,VKKEY)
      CALL WDVFKS(VKKEY)
      VKGRNO=ITGGRP
      VKKP=ITGPOS
      VKKS=ITGSIZ
      CALL VKMKKEY(VKCODE,VKGRNO,0,VKKEY)
      CALL WDVFKT(VKKEY)
************************************************************************
*
**  THE GROUP WHICH THE CHOSEN ITEM BELONGS TO IS ACCESSED AND CLOSED
**  TO FURTHER VERIFICATION KEY GENERATION
*
************************************************************************
      CALL RDRSP(TEMPKEY,300S)
      $MODGRP=1
      CALL RDRSP(TEMPKEY,400S)
************************************************************************
*
**  THE RSP FILE IS READ SEQUENTIALLY UNTIL SETS ARE ENCOUNTERED FOR
**  THAT GROUP-- IF THESE ARE UNMODIFIED(MODSET=0) VFK RECORDS ARE
**  GENERATED UNTIL ALL SETS FOR THIS GROUP HAVE BEEN PROCESSED
*
************************************************************************
      CALL RDRSP(RSPKEY,500S)
45    CONTINUE
      CALL RDRSPSEQ(NEXTRSP,399S)
      IF(RSPCODE.EQ.3)GO TO 45
50    CONTINUE
      IF($MODSET.NE.0)GO TO 55
      IF(PSCGNM.NE.VKGRNO)GO TO 55
      VKCODE=2
      VKGRNO=PSCGNM
      VKSTNO=PSETNM
      VKNPP=PSCNPOS
      VKKS=PSCNSIZ
      INQUIRE(RSPROG,KEY=CSGPKEY)
      CALL RDTCTEMP(CSGPKEY,101S)
      VKMFL=$MANUL
      CALL VKMKKEY(VKCODE,VKGRNO,VKSTNO,VKKEY)
      CALL WDVFKS(VKKEY)
      VKGRNO=PTGGNM
      VKNPP=PTGNPOS
      VKNPS=PTGNSIZ
      CALL WDVFKT(VKKEY)
55    CONTINUE
      CALL RDRSPSEQ(NEXTRSP,60S)
      IF(RSPCODE.EQ.4)GO TO 50
60    CONTINUE
      GO TO 5
199   OUTPUT 'UNABLE TO FIND DESIRED GROUP'
      GO TO 5
399   OUTPUT 'EOF ENCOUNTERED FOR RSP--NO SETS FOUND'
      GO TO 5
100   STOP 'UNABLE TO READ GRP REC FROM RSP FILE-GENVFK-VFKUSR'
101   STOP 'UNABLE TO READ GRP REC FROM CSGP FILE-GENVFK-VFKUSR'
200   STOP 'UNABLE TO READ ITEM REC FROM RSP FILE-GENVFK-VFKUSR'
300   STOP 'UNABLE TO READ RSP GRP REC FOR UPDATE-GENVFK-VFKUSR-'
400   STOP 'UNABLE TO WRITE RSP GRP REC UPDATE0GENVFK-VFKUSR'
500   STOP 'UNABLE TO REPOSITION RSP FILE AT ITM -GENVFK-VFKUSR'
600   OUTPUT 'YOU ARE NOT ALLOWED TO SELECT THIS GROUP'
      GO TO 5
700   OUTPUT 'THE ITEM IS NOT PART OF THIS GROUP--RETRY'
      GO TO 5
800   OUTPUT 'YOU ARE NOT ALLOWED TO SELECT THIS ITEM'
      GO TO 5
999   REWIND RSPROG
      REWIND TCSGP
1999  RETURN
      END
      SUBROUTINE RDTCTEMP(CSGPKEY,ERRSTAT)
************************************************************************
**************************** SUBROUTINE RDTCTEMP ************************
************************************************************************
*
**  READS ONE RECORD FROM KEYED TARGET CSGP FILE
**    AND STORES IT IN CONTREC
*
************************************************************************
      INCLUDE ERSP_IN01
      INTEGER ERRSTAT
      READ(TCSGP,'(300A4)',KEY=CSGPKEY,ERR=100)TEMPBUF
      RETURN
100   RETURN ERRSTAT
      END
      SUBROUTINE RDSQTEMP(SEQKEY,ERRSTAT)
*     SAME AS RDTCTEMP ONLY THE KEY IS CHARACTER*1
      INCLUDE ERSP_IN01
      CHARACTER*1 SEQKEY
      READ(TCSGP,'(300A4)',KEY=SEQKEY,ERR=100)TEMPBUF
      RETURN
100   RETURN ERRSTAT
      END
*
**  READS ONE RECORD FROM KEYED TARGET CSGP FILE
**    AND STORES IT IN BUFFER
*
************************************************************************
      SUBROUTINE RDTCBUFF(CSGPKEY,ERRSTAT)
      INCLUDE ERSP_IN01
      INTEGER ERRSTAT
      READ(TCSGP,'(300A4)',KEY=CSGPKEY,ERR=100)BUFFER
      RETURN
100   RETURN ERRSTAT
      END
      SUBROUTINE RDSQBUFF(SEQKEY,ERRSTAT)
*     SAME AS RDTCBUFF ONLY THE KEY IS CHARACTER*1
      INCLUDE ERSP_IN01
      INTEGER ERRSTAT
      CHARACTER*1 SEQKEY
      READ(TCSGP,'(300A4)',KEY=SEQKEY,ERR=100)  BUFFER
      RETURN
100   RETURN ERRSTAT
      END
      SUBROUTINE RDRSP(RSPKEY,ERRSTAT)
**  READS ONE RECORD FROM KEYED RSP FILE
      INCLUDE ERSP_IN02
      INTEGER ERRSTAT
      READ(RSPROG,'(80A4)',KEY=RSPKEY,ERR=100)RSPREC
      RETURN
100   RETURN ERRSTAT
      END
      SUBROUTINE RDRSPSEQ(SEQKEY,ERRSTAT)
*     SAME AS RDRSP ONLY THE KEY IS CHARACTER*1
      INCLUDE ERSP_IN02
      INCLUDE ERSP_IN01
      INTEGER ERRSTAT
      CHARACTER*1 SEQKEY
      READ(RSPROG,'(80A4)',KEY=SEQKEY,ERR=100)  RSPREC
      RETURN
100   RETURN ERRSTAT
      END
      SUBROUTINE WDCSGP(CSGPKEY,ERRSTAT)
**  WRITES ONE RECORD FOR EACH OF THE KEYED,  TARGET CSGP FILES'
      INCLUDE ERSP_IN01
      INTEGER ERRSTAT
      WRITE(TCSGP,'(300A4)',KEY=CSGPKEY,ERR=300)BUFFER
      RETURN
300   RETURN ERRSTAT
      END
      SUBROUTINE WDRSP(RSPKEY,ERRSTAT)
**  WRITES ONE RECORD FOR KEYED RSP FILE
      INTEGER ERRSTAT
      WRITE(RSPROG,'(80A4)',KEY=RSPKEY,ERR=400)RSPREC
      RETURN
400   RETURN ERRSTAT
      END
      SUBROUTINE WDTCTEMP(CSGPKEY,ERRSTAT)
      IMPLICIT LOGICAL(A-Z)
      INCLUDE ERSP_IN01
      INTEGER ERRSTAT
      WRITE(TCSGP,'(300A4)',KEY=CSGPKEY,ERR=100) TEMPBUF
      RETURN
100   RETURN ERRSTAT
      END
      SUBROUTINE CSGPDEL(CSGPKEY,ERRSTAT)
      IMPLICIT LOGICAL(A-Z)
      INCLUDE ERSP_IN01
      INTEGER ERRSTAT
      WRITE(TCSGP,'()',KEY=CSGPKEY,ERR=100)
      RETURN
100   RETURN ERRSTAT
      END
      SUBROUTINE RSPDEL(RSPKEY,ERRSTAT)
      IMPLICIT LOGICAL(A-Z)
      INCLUDE ERSP_IN02
      INTEGER ERRSTAT
      WRITE(RSPROG,'()',KEY=RSPKEY,ERR=100)
      RETURN
100   RETURN ERRSTAT
      END
      SUBROUTINE ASK(QUEST,STMNT1,STMNT2)
**    ASK CONSISTS OF 4 BASIC QUERY ROUTINES WHICH FORM THE BASIS
**    OF RSLUSR INTERACTION
*
** SUBROUTINE:        ASK - IS PASSED THREE PARAMETERS
*                                 A QUESTION REQUIRING A YES/NO(Y/N) ANS
*                                 A NO WILL RETURN TO STMNT1
*                                 A NULL RESPONSE WILL RETURN TO STMNT2
*                                 A YES TAKES THE NORMAL RETURN
*
**                    PNAME       ACCEPTS UP TO A 31 CHARACTER STRING
*
**                    PRMT        ACCEPTS A VALUE CHOSEN FROM AN
**                                ELIGIBLE RANGE OF 1-N, AS SPECIFIED
**                                DURING THE CALL
*
**                    PRMTV       ACCEPTS ANY NUMBER UP TO SOME MAX VAL
*
      INTEGER QUEST(1),KOUNT,I
      CHARACTER*1 N,Y,BLNK
      DATA N,Y,BLNK/'N','Y',' '/
      CHARACTER*1 ANS,NAME*31
      COMMON/QUERY/ANS,NAME
      CHARACTER*31,NN,YY,BLNK31
      DATA NN/'N'/
      DATA YY/'Y'/
      DATA BLNK31/' '/
      INTEGER BLNKI,NUM
      INTEGER RESP,VAL,MAXRESP,MAXVAL
      COMMON/QUERY1/RESP,VAL
      DATA BLNKI/0/
      KOUNT=(QUEST(0)+3)/4
5     CONTINUE
      WRITE(108,1)KOUNT,(QUEST(I),I=1,KOUNT)
1     FORMAT(1X,NA4)
      READ (105,2)ANS
2     FORMAT(A1)
      IF(ANS.EQ.N)RETURN STMNT1
      IF(ANS.EQ.BLNK)RETURN STMNT2
      IF(ANS.EQ.Y)RETURN
      GO TO 5
      ENTRY PNAME(QUEST,STMNT)
*************************************************************************
******************** SUBROUTINE PNAME *********************************
************************************************************************
      KOUNT=(QUEST(0)+3)/4
      WRITE(108,1)KOUNT,(QUEST(I),I=1,KOUNT)
      READ(105,3)NAME
3     FORMAT(A31)
      IF(NAME.EQ.BLNK31)RETURN               STMNT
      RETURN
      ENTRY PRMT(QUEST,MAXRESP,STMNT)
*********************************************************************
******************** SUBROUTINE PRMT **********************************
**********************************************************************
      KOUNT=(QUEST(0)+3)/4
15    CONTINUE
      WRITE(108,1)KOUNT,(QUEST(I),I=1,KOUNT)
      READ(105,4)RESP
4     FORMAT(I)
      IF(RESP.EQ.BLNKI)RETURN STMNT
      IF(RESP.GT.MAXRESP.OR.RESP.LE.0)GO TO 15
      RETURN
      ENTRY PRMTV(QUEST,MAXVAL,STMNT)
***********************************************************************
******************** SUBROUTINE PRMTV *********************************
*************************************************************************
      KOUNT=(QUEST(0)+3)/4
25    CONTINUE
      WRITE(108,1)KOUNT,(QUEST(I),I=1,KOUNT)
      READ(105,4)VAL
      IF(VAL.EQ.BLNKI)RETURN STMNT
      IF(VAL.GT.MAXVAL.OR.VAL.LT.0)GO TO 25
      RETURN
      END
      SUBROUTINE RSLUSR
*     RSLUSR OPENS AND CLOSES THE FILES FOR PROCESSING AND CALLS
*     THE COMMAND ROUTINE WHICH QUERIES THE USER FOR COMMANDS -RSLCOM-
      INCLUDE ERSP_IN01
      INCLUDE ERSP_IN02
      OPEN(TCSGP,STATUS='OLD',ACCESS='KEYED',FORM='FORMATTED',
     .     RECL=1200,ERR=100,KEYM=16,USAGE='UPDATE')
      OPEN(RSPROG,STATUS='OLD',ACCESS='KEYED',FORM='FORMATTED',
     .     RECL=320,ERR=200,KEYM=16,USAGE='UPDATE')
      CALL RSLCOM
      CLOSE(TCSGP,STATUS='KEEP',ERR=300)
      CLOSE(RSPROG,STATUS='KEEP',ERR=400)
      RETURN
100   STOP 'UNABLE TO OPEN TCSGP FILE -RSLUSR-'
200   STOP 'UNABLE TO OPEN RSPROG FILE -RSLUSR-'
300   STOP 'UNABLE TO CLOSE TCSGP FILE -RSLUSR-'
400   STOP 'UNABLE TO CLOSE RSPROG FILE -RSLUSR-'
      END
      SUBROUTINE RSLCOM
*     QUERIES THE USER FOR SCHEMA MODIFICATION COMMANDS AND DIRECTS
*     LOGIC TO APPROPRIATE MODIFICATION ROUTINE
      INTEGER INDEX,CLOGIC,FLOGIC
      CHARACTER*1 ANS,NAME*31,COMMAND*3,FIELD*3
      CHARACTER*3 COMTBL(4),FTBL(6)
      DATA COMTBL(1),COMTBL(2),COMTBL(3),COMTBL(4)
     *          /'ADD','MOD','DEL','END'/
      DATA FTBL(1),FTBL(2),FTBL(3),FTBL(4),FTBL(5),FTBL(6)
     *       /'ARE','GRP','INV','SET','MEM','ITM'/
1     CONTINUE
C     CALL ASK('DO YOU WISH TO MODIFY THE SCHEMA (Y/N)',99S,1S)
C PROCESS WAS NOT NEEDED.
       GO TO 999
5     CONTINUE
      OUTPUT 'ENTER COMMAND'
      READ(105,1000)COMMAND,FIELD
1000  FORMAT(A3,1X,A3)
      DO 10 INDEX=1,4
      IF(COMTBL(INDEX).EQ.COMMAND)CLOGIC=INDEX;
     *                GO TO(20,20,20,400)INDEX
10    CONTINUE
      OUTPUT 'THE SPECIFIED COMMAND IS INVALID'
      GO TO 5
20    DO 30 INDEX=1,6
      IF(FTBL(INDEX).EQ.FIELD)FLOGIC=INDEX;GO TO 40
30    CONTINUE
      OUTPUT ' OPTION MUST BE ONE OF - AREA SET ITM GRP INV '
      GO TO 5
40    GO TO (100,200,300,400)CLOGIC
      STOP 'THERE IS A SERIOUS LOGIC PROBLEM -RSLUSR--RSLCOM-'
100   CONTINUE
      GO TO(101,102,103,104,105,106)FLOGIC
101   CALL ADDARA
      GO TO 5
102   CALL ADDGRP
      GO TO 5
103   CALL ADDINV
      GO TO 5
104   CALL ADDSET
      GO TO 5
105   CALL ADDMEM
      GO TO 5
106   CALL ADDITM
      GO TO 5
200   CONTINUE
      GO TO (201,202,203,204,205,206)FLOGIC
201   CALL MODARA
      GO TO 5
202   CALL MODGRP
      GO TO 5
203   CALL MODINV
      GO TO 5
204   CALL MODSET
      GO TO 5
205   CALL MODMEM
      GO TO  5
206   CALL MODITM
      GO TO 5
300   CONTINUE
      GO TO(301,302,303,304,305,306)FLOGIC
301   CALL DELARA
      GO TO 5
302   CALL DELGRP
      GO TO 5
303   CALL DELINV
      GO TO 5
304   CALL DELSET
      GO TO 5
305   CALL DELMEM
      GO TO 5
306   CALL DELITM
      GO TO 5
  400 CALL FXFINC
99    CONTINUE
999   RETURN
      SUBROUTINE ADDARA
      INCLUDE ERSP_IN04
      INCLUDE ERSP_IN01
      INCLUDE ERSP_IN02
5     CONTINUE
      CALL PNAME('AREA NAME',99S)
      DO 10 INDEX=1,AREACNT
      IF(AREANMS(INDEX).EQ.NAME)GO TO 110
10    CONTINUE
      CALL PRMTV('AREA NUMBER (1-64)',64,99S)
      DO 20 INDEX=1,AREACNT
      IF(ARANUM(INDEX).EQ.VAL)GO TO 120
20    CONTINUE
      AREACNT=AREACNT+1
      AREANMS(AREACNT)=NAME
      ARANUM(AREACNT)=VAL
      CALL MAKEKEY(2,VAL,1,0,CSGPKEY)
100   CONTINUE
      CALL PRMTV('NUMBER OF PAGES',1048575,100S)
      ATGSIZ=$NPAGE=VAL
200   CONTINUE
      CALL PRMT('LINES PER PAGE (1-15/2-31/3-63/4-127/5-255)',5,200S)
      ATGLSZ=$DPLNN=RESP+3
300   CONTINUE
      CALL PRMTV('INVENTORY PERCENT (50-99)',99,300S)
      IF(VAL.LT.50)GO TO 300
      ATGINV=$INVPC=VAL
400   CONTINUE
      CALL ASK('CHECKSUM REQUIRED (Y/N)',490S,400S)
      ATGCHK=$CHKSM=1
      GO TO 510
490   ATGCHK=$CHKSM=0
500   CONTINUE
510   CALL ASK('JOURNAL REQUIRED (Y/N)',600S,500S)
      $JRNAL=1
      GO TO 610
600   $JRNAL=0
610   ATGNUM=$AREA=ARANUM(AREACNT)
      RSPCODE=$CODE=1
      $SBCOD=$AWSINC=$CIPHR=$FLPCT=$IKSIZ=0
      $PASIZ=512
      $OVMIN=$OVMAX=-1
      RSPSORT=ASCNUM=ASCSIZ=ASCLSZ=ASCCHK=ATGFIL=0
      CALL ATOI(NAME,BUFFER(18))
      DO 40 INDEX=18,(31+18)
      IF(BUFFER(INDEX).EQ.BLNK1)$NMCNT=INDEX-18;GO TO 45
40    CONTINUE
      $NMCNT=31
45    CALL WDCSGP(CSGPKEY,99S)
      ENCODE (32,31,RSPNAM) NAME
31    FORMAT(31A1)
      CALL WDRSP(CSGPKEY,99S)
99    RETURN
110   OUTPUT 'AREA NAME ALREADY EXISTS'
120   OUTPUT 'AREA NUMBER ALREADY EXISTS'
      GO TO 10
      END
      SUBROUTINE ATOI(NAMEA31,NAMEA1)
      INTEGER INDEX
      CHARACTER*31 NAMEA31
      INTEGER NAMEA1(1)
      READ(NAMEA31,'(31A1)'),(NAMEA1(INDEX),INDEX=1,31)
      RETURN
      END
      SUBROUTINE ADDGRP
      INCLUDE ERSP_IN04
      INCLUDE ERSP_IN01
      INTEGER GPRIME
5     CONTINUE
      CALL PNAME('GROUP NAME',999S)
      DO 10 INDEX=1,GRPCNT
      IF(GRPNMS(INDEX).NE.NAME)GO TO 10
      OUTPUT 'THIS GROUP NAME ALREADY EXISTS'
      GO TO 999
10    CONTINUE
      CALL PRMTV('GROUP NUMBER',900,10S)
      DO 20 INDEX=1,GRPCNT
      IF(GRPNUM(INDEX).NE.VAL)GO TO 20
      OUTPUT 'GROUP NUMBER ALREADY EXISTS'
      GO TO 10
20    CONTINUE
      GRPNMS(GRPCNT+1)=NAME
      GRPNUM(GRPCNT+1)=VAL
30    CONTINUE
      CALL PNAME('AREA NAME',30S)
      DO 40 INDEX=1,AREACNT
      IF(AREANMS(INDEX).EQ.NAME)$AREA=ARANUM(INDEX);GO TO 50
40    CONTINUE
      OUTPUT 'THIS AREA IS NOT PART OF THE SCHEMA'
      GO TO 30
50    $CODE=GRCODE
      $SBCOD=0
      GRPCNT=GRPCNT+1
      $GRPNM=GRPNUM(GRPCNT)
      $GWSINC=$STREL=$RTLOK=$UPLOK=0
      $GRTYP=1
      $DBGSZ=1
      $BYTES=4
      $WSSIZ=0
      CALL MAKEKEY(2,$AREA,1,0,CSGPKEY)
      CALL RDTCTEMP(CSGPKEY,1000S)
60    CONTINUE
      CALL PRMTV('LOW PAGE RANGE',TEMPBUF(5),60S)
      $GPGMIN=VAL
70    CONTINUE
      CALL PRMTV('HIGH PAGE RANGE',TEMPBUF(5),70S)
      $GPGMAX=VAL
      IF($GPGMIN.GT.$GPGMAX)
     : OUTPUT 'RANGE SPECIFIED IN ERROR';GO TO 60
      $PGPRM=GPRIME($GPGMIN,$GPGMAX)
      $CNREC=$MANUL=$GSTATS=$DUPE=0
      CALL ATOI(GRPNMS(GRPCNT),BUFFER(21))
      $NSIZE=31
90    CALL MAKEKEY(3,$GRPNM,1,0,CSGPKEY)
      CALL WDCSGP(CSGPKEY,2000S)
      $SBCOD=25
      $CONT=0
      DO 100 INDEX=5,300
      BUFFER(INDEX)=0
100   CONTINUE
      CALL MAKEKEY(3,$GRPNM,4,0,CSGPKEY)
      CALL WDCSGP(CSGPKEY,3000S)
999   RETURN
1000  STOP 'UNABLE TO READ TCSGP AREA REC -ADDGRP-'
2000  STOP 'UNABLE TO WRITE TCSGP AREA REC -ADDGRP-'
3000  STOP 'UNABLE TO WRITE TCSGP CONTROL ITEM REC -ADDGRP-'
      END
      SUBROUTINE ADDMEM
      INCLUDE ERSP_IN04
      INCLUDE ERSP_IN01
      INTEGER TSETN,TGRPN,OPRIOR
5     CONTINUE
      CALL PNAME('SET NAME',999S)
      DO 10 INDEX=1,SETCNT
      IF(SETNMS(INDEX).EQ.NAME)TSETN=SETNUM(INDEX);GO  TO 15
10    CONTINUE
      OUTPUT 'THIS SET IS NOT PART OF THE SCHEMA, SET MUST EXIST'
      GO TO 999
15    CONTINUE
      CALL PNAME('GROUP NAME',999S)
      DO 30 INDEX=1,GRPCNT
      IF(GRPNMS(INDEX).EQ.NAME)TGRPN=GRPNUM(INDEX);GO   TO 40
30    CONTINUE
      OUTPUT 'THIS GROUP IS NOT PART OF THE SCHEMA, GRP MUST EXIST'
      GO TO 999
40    CALL MAKEKEY(4,TSETN,1,0,CSGPKEY)
      CALL RDTCBUFF(CSGPKEY,70S)
      OPRIOR=SPRIOR
      IF($OGRP.NE.TGRPN)GO   TO 45
      OUTPUT 'YOU HAVE SELECTED THE OWNER GROUP OF THIS SET'
      GO TO 15
45    CONTINUE
      CALL RDSQBUFF(NEXTKEY,50S)
      IF($SBCOD.NE.MMCODE)GO TO 50
      IF($MGRPNM.NE.TGRPN)GO TO 45
      OUTPUT 'THIS GROUP IS ALREADY A MEMBER OF THE SET'
      GO TO 15
*
**  FINDS CURRENT AREA FOR MEMBER RECORD
*
50    CALL MAKEKEY(3,TGRPN,1,0,TEMPKEY)
      $AREA=TEMPBUF(1)
      $CODE=STCODE
      $SBCOD=MMCODE
      $MSETN=TSETN
      $MGRPNM=TGRPN
      $ALIAS=$OPTON=0
      $PRIOR=OPRIOR
      $PHEAD=$PNEXT=1
100   CONTINUE
      CALL ASK('INCLUSION IS AUTOMATIC (Y/N)',110S,100S)
      $MMANUL=0
      GO TO 210
110   $MMANUL=1
200   CONTINUE
210   CALL PRMT('ORDER IS: 1-FIRST,2-LAST,3-NEXT,4-PRIOR',4,200S)
      GO TO(211,212,213,214)RESP
211   $ORDER=8
      GO TO 220
212   $ORDER=0
      GO TO 220
213   $ORDER=9
      GO TO 220
214   $ORDER=1
220   $MDUPE=$SELEC=$STSET=$STGRP=$PRIME=$MCOUNT=$ALIAC=0
      $PSET=$CSET=$SORT=0
*
**    TRANSFER NAME TO RECORD AND DETERMINE SIZE
*
      CALL ATOI(NAME,BUFFER(24))
      DO 300 INDEX=24,(24+31)
      IF(BUFFER(INDEX).EQ.BLNK1)$MNSIZ=INDEX-24;GO TO 400
300   CONTINUE
*
**    NEW RECORDS ARE ADDED TO THE TCSGP FILE ONLY
*
400   CALL MAKEKEY(4,$MSETN,2,$MGRPNM,CSGPKEY)
      CALL WDCSGP(CSGPKEY,4000S)
      CALL MAKEKEY(3,$MGRPNM,6,$MSETN,CSGPKEY)
      CALL WDCSGP(CSGPKEY,5000S)
999   RETURN
70    STOP 'UNABLE TO READ TCSGP SET OWNER REC -ADDMEM-'
1000  STOP 'UNABLE TO READ TCSGP GROUP REC -ADDMEM-'
4000  STOP 'UNABLE TO WRITE TCSGP(4,-,2,-)REC -ADDMEM-'
5000  STOP 'UNABLE TO WRITE TCSGP(3,-,6,-)REC -ADDMEM-'
      END
      SUBROUTINE ADDSET
      INCLUDE ERSP_IN04
      INCLUDE ERSP_IN01
      CHARACTER*31 SNAME
      INTEGER HASHED
5     CONTINUE
      CALL PNAME('SET NAME',999S)
      DO 20 INDEX=1,SETCNT
      IF(SETNMS(INDEX).NE.NAME)GO TO 20
10    OUTPUT 'A SET WITH THIS NAME ALREADY EXISTS'
      GO TO 999
      SNAME=NAME
25    CONTINUE
      CALL PNAME('OWNER GROUP NAME',5S)
      DO 30 INDEX=1,GRPCNT
      IF(GRPNMS(INDEX).EQ.NAME)$OGRP=GRPNUM(INDEX);
     : CALL ATOI(GRPNMS(INDEX),BUFFER(12));GO TO 40
30    CONTINUE
      OUTPUT 'SET CREATION REQUIRES PREVIOUSLY DEFINED OWNER GROUP'
      GO TO 999
40    CALL PNAME('MEMBER GROUP NAME',5S)
      DO 50 INDEX=1,GRPCNT
      IF(GRPNMS(INDEX).EQ.NAME)TGRP=GRPNUM(INDEX);GO TO 60
50    CONTINUE
      OUTPUT 'SET CREATION REQUIRES PREVIOUSLY DEFINED MEMBER GROUP'
      GO TO 999
60    SETCNT=SETCNT+1
      SETNMS(SETCNT)=SNAME
      DO 65 INDEX=12,(12+31)
      IF(BUFFER(INDEX).EQ.BLNK1)$ONSIZ=INDEX-12;GO TO 70
65    CONTINUE
      $ONSIZ=31
70    CALL ATOI(SNAME,BUFFER(13+$ONSIZ))
      DO 75 INDEX=(13+$ONSIZ),(13+$ONSIZ+31)
      IF(BUFFER(INDEX).EQ.BLNK1)BUFFER(12+$ONSIZ)=INDEX;GO TO 79
75    CONTINUE
      BUFFER(12+$ONSIZ)=31
79    $SETN=SETNUM(SETCNT)=HASHED(BUFFER(12+$ONSIZ),0)
      CALL MAKEKEY(3,$OGRP,1,0,TEMPKEY)
      CALL RDTCTEMP(TEMPKEY,1000S)
      $AREA=TEMPBUF(1)
      $CODE=TEMPBUF(2)=STCODE
      $SBCOD=0
      TEMPBUF(3)=MMCODE
      TEMPBUF(4)=$SETN
      TEMPBUF(5)=TGRP
      $SPNEXT=$SPRIOR=TEMPBUF(6)=TEMPBUF(7)=1
      TEMPBUF(8)=0
      TEMPBUF(9)=TEMPBUF(10)=0
      $OTYPE=0
80    CONTINUE
      CALL PRMT('SET ORDER IS: 1-FIRST,2-LAST,3-NEXT,4-PRIOR',4,80S)
      GO TO(81,82,83,84)RESP
81    $SORDER=8
      GO TO 90
82    $SORDER=0
      GO TO 90
83    $SORDER=9
      GO TO 90
84    $SORDER=1
90    CONTINUE
      CALL ASK('STATISTICS (Y/N)',100S,90S)
      $SSTATS=1
      GO TO 150
100   $SSTATS=0
150   CONTINUE
      CALL ASK('MEMBER INCLUSION IS AUTOMATIC (Y/N)',160S,150S)
      TEMPBUF(11)=0
      GO TO 200
160   TEMPBUF(11)=1
200   CONTINUE
      CALL PRMT('MEMBER ORDER IS: 1-FIRST,2-LAST,3-NEXT,4-PRIOR',4,200S)
      GO TO(201,202,203,204)RESP
201   TEMPBUF(15)=8
      GO TO 210
202   TEMPBUF(15)=0
      GO TO 210
203   TEMPBUF(15)=9
      GO TO 210
204   TEMPBUF(15)=1
210   TEMPBUF(13)=TEMPBUF(14)=TEMPBUF(16)=TEMPBUF(12)=TEMPBUF(18)=0
      TEMPBUF(17)=1
      TEMPBUF(19)=TEMPBUF(20)=TEMPBUF(21)=TEMPBUF(22)=0
      DO 250 INDEX=1,GRPCNT
      IF(GRPNUM(INDEX).EQ.TGRP)CALL ATOI(GRPNMS(INDEX),TEMPBUF(24));
     :                            GO TO 270
250   CONTINUE
270   DO 280 INDEX=24,(24+31)
      IF(TEMPBUF(INDEX).EQ.BLNK1)TEMPBUF(23)=INDEX-24;GO TO 300
280   CONTINUE
      TEMPBUF(23)=31
300   TEMPBUF(TEMPBUF(23)+24)=0
C     SAY THRER R NO SORT KEYS
      CALL MAKEKEY(3,$OGRP,6,$SETN,CSGPKEY)
      CALL MAKEKEY(3,TGRP,6,$SETN,TEMPKEY)
      CALL WDCSGP(CSGPKEY,2000S)
      CALL WDTCTEMP(TEMPKEY,2222S)
      CALL MAKEKEY(4,$SETN,1,0,CSGPKEY)
      CALL MAKEKEY(4,$SETN,2,TGRP,TEMPKEY)
      CALL WDCSGP(CSGPKEY,3000S)
      CALL WDTCTEMP(TEMPKEY,3333S)
999   RETURN
1000  STOP 'UNABLE TO READ TCSGP OWNER GROUP REC -ADDSET-'
2000  STOP 'UNABLE TO WRITE TCSGP OWNER SET REC(3,-,6,-) -ADDSET-'
2222  STOP 'UNABLE TO WRITE TCSGP MEMBER SET REC(3,-,6,-) -ADDSET-'
3000  STOP 'UNABLE TO WRITE TCSGP OWNER SET REC(4,-,1,0) -ADDSET-'
3333  STOP 'UNABLE TO WRITE TCSGP MEMBER SET REC(4,-,2,-) -ADDSET-'
      END
      SUBROUTINE DELARA
      INCLUDE ERSP_IN04
      INCLUDE ERSP_IN01
      INCLUDE ERSP_IN02
      INTEGER TLNTH
      TLNTH=AREACNT
5     CONTINUE
      CALL PNAME('AREA NAME',99S)
      DO 10 INDEX=1,TLNTH
      IF(AREANMS(INDEX).EQ.NAME)
     .   $AREA=ARANUM(INDEX);GO  TO 20
10    CONTINUE
      OUTPUT 'THIS AREA NAME DOES NOT EXIST -CANNOT DELETE-'
      GO TO 99
20    AREANMS(INDEX)='..DELETED'
      ARANUM(INDEX)=0
30    CALL MAKEKEY(2,$AREA,1,0,CSGPKEY)
      CALL CSGPDEL(CSGPKEY,1000S)
      CALL RSPDEL(CSGPKEY,2000S)
99    RETURN
1000  STOP 'UNABLE TO DELETE TCSGP AREA REC -DELARA-'
2000  STOP 'UNABLE TO DELETE RSP AREA REC -DELARA-'
      END
      SUBROUTINE DELMEM
      INCLUDE ERSP_IN04
      INCLUDE ERSP_IN01
      INCLUDE ERSP_IN02
      TCOUNT=0
5     CONTINUE
      CALL PNAME('SET NAME',999S)
      DO 10 INDEX=1,SETCNT
      IF(SETNMS(INDEX).EQ.NAME)TSET=SETNUM(INDEX);GO TO 20
10    CONTINUE
      OUTPUT 'THIS SET IS NOT PART OF THE SCHEMA'
      GO TO 5
20    CONTINUE
      CALL PNAME('MEMBER NAME',999S)
      DO 30 INDEX=1,GRPCNT
      IF(GRPNMS(INDEX).EQ.NAME)TGRP=GRPNUM(INDEX);GO TO 40
30    CONTINUE
      OUTPUT 'THIS GROUP IS NOT PART OF THE SCHEMA, CANNOT DELETE'
      GO TO 20
40    CALL MAKEKEY(4,TSET,2,TGRP,CSGPKEY)
      CALL RDTCBUFF(CSGPKEY,1010S)
      CALL MAKEKEY(4,TSET,1,0,CSGPKEY)
      CALL RDTCBUFF(CSGPKEY,1000S)
45    CONTINUE
      CALL RDSQTEMP(NEXTKEY,60S)
      IF(TEMPBUF(4).NE.TSET)GO TO 60
      IF(TEMPBUF(5).NE.TGRP)GO TO 50
      INQUIRE(TCSGP,KEY=CSGPKEY)
      CALL RDTCBUFF(CSGPKEY,2000S)
      CALL CSGPDEL(CSGPKEY,5000S)
50    TCOUNT=TCOUNT+1
      GO TO 45
60    IF($ALIAS.EQ.0)GO TO 100
      CALL MAKEKEY(4,$MSETN,3,0,CSGPKEY)
      CALL RDTCTEMP(CSGPKEY,3000S)
70    CONTINUE
      INQUIRE(TCSGP,KEY=TEMPKEY)
      IF(TEMPBUF(5).EQ.$MGRPNM)WRITE(TCSGP,'( )',KEY=TEMPKEY)
      CALL RDSQTEMP(NEXTKEY,100S)
      IF(TEMPBUF(3).EQ.ALCODE)GO TO 70
100   CALL MAKEKEY(3,TGRP,6,$MSETN,CSGPKEY)
      CALL CSGPDEL(CSGPKEY,5000S)
      CALL RSPDEL(CSGPKEY,5000S)
      IF($ORDER.NE.4)GO TO 200
      CALL MAKEKEY(3,TGRP,4,0,CSGPKEY)
      CALL RDTCBUFF(CSGPKEY,4000S)
      DO 150 INDEX=6,(BUFFER(6)+(BUFFER(5)*4)),4
      IF((BUFFER(INDEX).EQ.4.OR.BUFFER(INDEX).EQ.6).AND.
     : (BUFFER(INDEX+3).EQ.TSET))BUFFER(INDEX)=0;
     :CALL WDCSGP(CSGPKEY,5000S); GO TO 200
150   CONTINUE
200   IF(TCOUNT.GT.1)GO TO 999
      CALL MAKEKEY(4,TSET,1,0,CSGPKEY)
      CALL RDTCBUFF(CSGPKEY,1000S)
      CALL CSGPDEL(CSGPKEY,5000S)
      CALL MAKEKEY(3,$OGRP,6,$SETN,CSGPKEY)
      CALL CSGPDEL(CSGPKEY,5000S)
      CALL RSPDEL(CSGPKEY,5000S)
300   TCOUNT=SETCNT
      DO 350 INDEX=1,TCOUNT
      IF(SETNUM(INDEX).EQ.TSET)SETNUM(INDEX)=0;
     .                          SETNMS(INDEX)='..DELETED'; GO TO 999
350   CONTINUE
999   RETURN
1000  STOP 'UNABLE TO READ TCSGP SET OWNER REC(4,-,1,0) -DELMEM-'
1010  OUTPUT ' THIS GROUP IS NOT A MEMBER OF THE SPECIFIED SET'
      GO TO 999
2000  STOP 'UNABLE TO READ TCSGP MEM REC TO DELETE(4,-,2,-) -DELMEM-'
3000  STOP 'UNABLE TO READ TCSGP ALIAS REC -DELMEM-'
4000  STOP 'UNABLE TO READ TCSGP CONTROL ITM REC -DELMEM-'
5000  STOP 'UNABLE TO WRITE TCSGP CONTROL ITM REC -DELMEM-'
      END
      SUBROUTINE DELSET
      INCLUDE ERSP_IN04
      INCLUDE ERSP_IN01
      INCLUDE ERSP_IN02
5     CONTINUE
      CALL PNAME('SET NAME',999S)
      DO 10 INDEX=1,TCOUNT
      IF(SETNMS(INDEX).EQ.NAME)TSET=SETNUM(INDEX);
     :                            GO TO 15
10    CONTINUE
      OUTPUT 'THIS SET IS NOT PART OF THE SCHEMA -CANNOT DELETE'
      GO TO 5
15    SETNMS(INDEX)='..DELETED';SETNUM(INDEX)=0
20    CALL MAKEKEY(4,TSET,1,0,CSGPKEY)
      CALL RDTCBUFF(CSGPKEY,1000S)
      CALL MAKEKEY(3,$OGRP,6,$SETN,RSPKEY)
25    CALL CSGPDEL(RSPKEY,5000S)
      CALL RSPDEL(RSPKEY,5000S)
      CALL CSGPDEL(CSGPKEY,5000S)
30    CONTINUE
      CALL RDSQBUFF(NEXTKEY,999S)
      IF($MSETN.NE.TSET)GO TO 999
      INQUIRE(TCSGP,KEY=CSGPKEY)
      CALL MAKEKEY(3,$MGRPNM,6,$MSETN,RSPKEY)
      IF($ORDER.NE.4)GO TO 90
      CALL MAKEKEY(3,$MGRPNM,4,0,TEMPKEY)
      CALL RDTCBUFF(TEMPKEY,4000S)
      DO 80 INDEX=6,(BUFFER(6)+(BUFFER(5)*4)),4
      IF((BUFFER(INDEX).EQ.4.OR.BUFFER(INDEX).EQ.6).AND.
     : (BUFFER(INDEX+3).EQ.TSET))BUFFER(INDEX)=0;
     : CALL WDCSGP(TEMPKEY,5000S)
80    CONTINUE
      OUTPUT 'SORT ITEMS NOT INCLUDED IN CNTRL ITEM REC -DELSET-'
90    CALL CSGPDEL(RSPKEY,5000S)
      CALL RSPDEL(RSPKEY,5000S)
      CALL CSGPDEL(CSGPKEY,5000S)
      GO TO 30
999   RETURN
1000  STOP 'UNABLE TO READ TCSGP SET OWNER REC(4,-,1,0) -DELSET-'
4000  STOP 'UNABLE TO READ MEMBER GROUP CNTRL REC -DELSET-'
5000  STOP 'UNABLE TO WRITE MEMBER GROUP CNTRL REC -DELSET-'
      END
      SUBROUTINE MODARA
      INCLUDE ERSP_IN04
      INCLUDE ERSP_IN01
      INCLUDE ERSP_IN02
      INTEGER GPRIME
5     CONTINUE
      CALL PNAME('AREA NAME',100S)
      DO 10 INDEX=1,AREACNT
10    CONTINUE
      OUTPUT 'THIS AREA NAME IS NOT PART OF THE SCHEMA-CANNOT MODIFY'
      GO TO 5
20    CALL MAKEKEY(2,$AREA,1,0,CSGPKEY)
      CALL RDTCBUFF(CSGPKEY,1000S)
      CALL RDRSP(CSGPKEY,1001S)
      TEMPBUF(1)=$AREA
      CALL PRMTV('NUMBER OF PAGES',1048575,200S)
      TEMPBUF(2)=ATGSIZ=$NPAGE=VAL
200   CALL PRMT('LINES PER PAGE (1-15/2-31/3-63/4-127/5-255)',5,300S)
      ATGLSZ=$DPLNN=RESP+3
30    CONTINUE
300   CALL PRMTV('INVENTORY PERCENT (50-99)',99,400S)
      IF(VAL.LT.50)GO TO 30
      ATGINV=$INVPC=VAL
400   CALL ASK('CHECKSUM REQUIRED (Y/N)',500S,510S)
      ATGCHK=$CHKSM=1
      GO TO 510
500   ATGCHK=$CHKSM=0
510   CALL ASK('JOURNAL REQUIRED (Y/N)',600S,610S)
      $JRNAL=1
      GO TO 610
600   $JRNAL=0
610   CALL WDCSGP(CSGPKEY,2000S)
      CALL WDRSP(CSGPKEY,2001S)
      DO 700 INDEX=1,(GRPCNT-1)
      CALL MAKEKEY(3,GRPNUM(INDEX),1,0,CSGPKEY)
      CALL RDTCBUFF(CSGPKEY,3000S)
      IF($GPGMN.NE.-1.OR.$GPGMAX.NE.-1.OR.$GRTYP.NE.2.OR.
     .                            $AREA.NE.TEMPBUF(1))GO TO 700
      CALL RDRSP(CSGPKEY,4000S)
      GTGPRV=$PGPRM=GPRIME(1,TEMPBUF(2))
      CALL WDCSGP(CSGPKEY,3001S)
      CALL WDRSP(CSGPKEY,4001S)
700   CONTINUE
100   RETURN
1000  STOP 'UNABLE TO READ AREA FROM TCSGP FILE -MODARA-'
2000  STOP 'UNABLE TO WRITE AREA TO TCSGP FILE -MODARA-'
1001  STOP 'UNABLE TO READ AREA FROM RSP FILE -MODARA-'
2001  STOP 'UNABLE TO WRITE AREA TO RSP FILE -MODARA-'
3000  STOP 'UNABLE TO READ GROUP FROM TCSGP FILE -MODARA-'
3001  STOP 'UNABLE TO WRITE GROUP TO TCSGP FILE -MODARA-'
4000  STOP 'UNABLE TO READ GROUP FROM RSP FILE -MODARA-'
      END
      SUBROUTINE MODMEM
      INCLUDE ERSP_IN04
      INCLUDE ERSP_IN01
5     CONTINUE
      CALL PNAME('SET NAME',999S)
      DO 10 INDEX=1,SETCNT
      IF(SETNMS(INDEX).EQ.NAME)$MSETN=SETNUM(INDEX);GO TO 20
10    CONTINUE
      OUTPUT 'THIS SET IS NOT PART OF THE SCHEMA, SET MUST EXIST'
      GO TO 5
15    CONTINUE
20    CALL PNAME('MEMBER NAME',999S)
      DO 30 INDEX=1,GRPCNT
      IF(GRPNMS(INDEX).EQ.NAME)$MGRPNM=GRPNUM(INDEX);GO TO 40
30    CONTINUE
      OUTPUT 'THIS GROUP IS NOT PART OF THE SCHEMA, GRP MUST EXIST'
      GO TO 15
40    CALL MAKEKEY(4,$MSETN,2,$MGRPNM,CSGPKEY)
      CALL RDTCBUFF(CSGPKEY,1000S)
      CALL ASK('INCLUSION IS AUTOMATIC (Y/N)',100S,200S)
      $MMANUL=0
      GO TO 200
100   $MMANUL=1
200   CALL PRMT('ORDER IS: 1-FIRST,2-LAST,3-NEXT,4-PRIOR',4,300S)
      IF($ORDER.NE.4)GO  TO 250
      CALL MAKEKEY(3,$MGRPNM,4,0,TEMPKEY)
      CALL RDTCTEMP(TEMPKEY,4000S)
      DO 225 INDEX=6,(TEMPBUF(6)+(TEMPBUF(5)*4))
      IF((TEMPBUF(INDEX).EQ.4.OR.TEMPBUF(INDEX).EQ.6).AND.
     : (TEMPBUF(INDEX+3).EQ.$SETN))TEMPBUF(INDEX)=0
225   CONTINUE
      CALL WDTCTEMP(TEMPKEY,5000S)
250   GO TO(201,202,203,204)RESP
201   $ORDER=8
      GO TO 300
202   $ORDER=0
      GO TO 300
203   $ORDER=9
      GO TO 300
204   $ORDER=1
300   CALL WDCSGP(CSGPKEY,2000S)
      CALL MAKEKEY(3,$MGRPNM,6,$MSETN,CSGPKEY)
      CALL WDCSGP(CSGPKEY,3000S)
999   RETURN
1000  OUTPUT 'THIS GROUP DOES NOT PARTICIPATE IN SPECIFIED SET'
      GO TO 15
2000  STOP 'UNABLE TO WRITE MODIFIED TCSGP(4,-,2,-)REC -MODMEM-'
4000  STOP 'UNABLE TO READ TCSGP CONTROL ITM REC -MODMEM-'
5000  STOP 'UNABLE TO WRITE TCSGP CONTROL ITM REC -MODMEM-'
      END
      SUBROUTINE MODSET
      INCLUDE ERSP_IN04
      INCLUDE ERSP_IN01
5     CONTINUE
      CALL PNAME('SET NAME',999S)
      DO 10 INDEX=1,SETCNT
      IF(SETNMS(INDEX).EQ.NAME)$SETN=SETNUM(INDEX);GO TO 20
10    CONTINUE
      OUTPUT 'THIS SET IS NOT PART OF THE SCHEMA, CANNOT MODIFY'
      GO TO 5
20    CALL MAKEKEY(4,$SETN,1,0,CSGPKEY)
      CALL RDTCBUFF(CSGPKEY,1000S)
      CALL PRMT('ORDER IS: 1-FIRST,2-LAST,3-NEXT,4-PRIOR',4,100S)
98    GO TO (21,22,23,24)RESP
21    $SORDER=8
      GO TO 100
22    $SORDER=0
      GO TO 100
23    $SORDER=9
      GO TO 100
24    $SORDER=1
100   CALL ASK('STATISTICS (Y/N)',110S,200S)
      $SSTATS=1
      GO TO 200
110   $SSTATS=0
200   CALL WDCSGP(CSGPKEY,2000S)
      CALL MAKEKEY(3,$OGRP,6,$SETN,CSGPKEY)
      CALL WDCSGP(CSGPKEY,3000S)
999   RETURN
1000  STOP 'UNABLE TO READ TCSGP SET OWNER REC -MODSET-'
2000  STOP 'UNABLE TO WRITE TCSGP SET (4,-,1,-,0) REC -MODSET-'
3000  STOP 'UNABLE TO WRITE TCSGP SET (3,-,6,-) REC -MODSET-'
      END
      SUBROUTINE FXFINC
      IMPLICIT LOGICAL (A-Z,$)
      INCLUDE ERSP_IN01
      INCLUDE ERSP_IN02
      PARAMETER E$EOF=1536
      INTEGER NWFINC,CGRPNO,EOFCSGP,RSPFLG,DBYTES
      CALL MAKEKEY(1,0,0,0,CSGPKEY)
*
3     CALL RDTCBUFF(CSGPKEY,300S)
4     CALL RDSQBUFF(NEXTKEY,800S)
         IF($CODE.NE.2)GO TO 4
5     IF($CODE.EQ.2.AND.$SBCOD.EQ.0) NWFINC=4;DBYTES=0;
     1CGRPNO=$GRPNM;GO TO 7
      GO TO 10
7     IF($GRTYP.EQ.2)NWFINC=8
      INQUIRE(TCSGP,KEY=CSGPKEY,ERR=500,ERRCODE=EOFCSGP)
      IF(EOFCSGP.EQ.E$EOF) RETURN
      IF(CSGPKEY(1:2).EQ.' 4') RETURN
      IF($CODE.EQ.2.AND.$SBCOD.EQ.30) GO TO 50
      IF($CODE.EQ.3.AND.$SBCOD.EQ.0) GO TO 60
      IF($CODE.EQ.3.AND.$SBCOD.EQ.10) GO TO 70
      IF($GRPNM.NE.CGRPNO)  GO TO 40
      GO TO 5
*
*     CHANGE IN GROUP NUMBER
*
40    INQUIRE(TCSGP,KEY=TEMPKEY)
      CALL MAKEKEY(3,CGRPNO,1,0,CSGPKEY)
      CALL RDTCBUFF(CSGPKEY,800S)
45    CALL RDRSP(CSGPKEY,46S)
      RSPFLG=1;GO TO 47
46    RSPFLG=0
47    CONTINUE
      $BYTES=DBYTES
      $DBGSZ=(NWFINC+3)/4
      GTGSIZ=$DBGSZ
      CALL WDCSGP(CSGPKEY,800S)
      IF(RSPFLG.EQ.1)CALL WDRSP(CSGPKEY,700S)
      INQUIRE(TCSGP,ERRCODE=EOFCSGP)
      IF (EOFCSGP.EQ.E$EOF) RETURN
      CALL RDTCBUFF(TEMPKEY,800S)
      DBYTES=0
      GO TO 5
*
*     A (2,30) RECORD
*
50    $FINC=NWFINC
      CALL RDRSP(CSGPKEY,51S)
      RSPFLG=1;GO TO 52
51    RSPFLG=0
52    CONTINUE
      ITGPOS=$FINC
      WRITE(TCSGP,'(300A4)',KEY=CSGPKEY,ERR=800) BUFFER
      IF(RSPFLG.EQ.1)CALL WDRSP(CSGPKEY,700S)
      NWFINC=NWFINC+$ISIZE ; DBYTES=DBYTES+$ISIZE
      GO TO 5
*
*     A (3,0) RECORD
*
60    $SPNEXT=NWFINC
      IF($SPRIOR.EQ.0) GO TO 65
      NWFINC=NWFINC+$TSPSIZ
      $SPRIOR=NWFINC
65    NWFINC=NWFINC+$TSPSIZ
      CALL RDRSP(CSGPKEY,66S)
      RSPFLG=1;GOTO 67
66    RSPFLG=0
67    CONTINUE
      PTGNPOS=$SPNEXT
      PTGPPOS=$SPRIOR
      CALL WDCSGP(CSGPKEY,800S)
      IF(RSPFLG.EQ.1)CALL WDRSP(CSGPKEY,700S)
      INQUIRE(TCSGP,KEY=TEMPKEY,ERR=800)
      CALL MAKEKEY(4,$SETN,1,0,CSGPKEY)
      CALL WDCSGP(CSGPKEY,800S)
      CALL RDTCBUFF(TEMPKEY,300S)
      GO TO 5
*
*     A (3,10) RECORD
*
70    $PNEXT=NWFINC
      IF($PRIOR.EQ.0)  GO TO 72
      NWFINC=NWFINC+$TSPSIZ
      $PRIOR=NWFINC
72    CONTINUE
      IF($PHEAD.EQ.0) GO TO 74
      NWFINC=NWFINC+$TSPSIZ
      $PHEAD=NWFINC
74    NWFINC=NWFINC+$TSPSIZ
      CALL                RDRSP(CSGPKEY,76S)
      RSPFLG=1;GOTO 77
76    RSPFLG=0
77    CONTINUE
      PTGNPOS=$PNEXT
      PTGPPOS=$PRIOR
      PTGOPOS=$PHEAD
      CALL WDCSGP(CSGPKEY,800S)
      IF(RSPFLG.EQ.1)CALL WDRSP(CSGPKEY,700S)
      INQUIRE(TCSGP,KEY=TEMPKEY,ERR=700)
      CALL MAKEKEY(4,$MSETN,2,$MGRPNM,CSGPKEY)
      CALL WDCSGP(CSGPKEY,800S)
      CALL RDTCBUFF(TEMPKEY,400S)
      GO TO 5
300   STOP 'KEY 1,0,0,0 WAS NOT FOUND IN TCSGP -FXFINC-'
400   STOP 'ERROR READING NEXT RECORD IN TCSGP FILE -FXFINC-'
500   STOP 'INQUIRE FAILED FOR KEY ON TCSGP -FXFINC-'
700   STOP 'KEY IN RSP DOES NOT EXIST -FXFINC-'
800   STOP 'KEY IN TCSGP DOES NOT EXIST -FXFINC-'
      END
      SUBROUTINE DELGRP
      INCLUDE ERSP_IN04
      INCLUDE ERSP_IN01
      INCLUDE ERSP_IN02
      INTEGER TPOS,NRK
      CHARACTER * 16 RKEY(50)
5     CALL PNAME (' GROUP NAME',99S)
      DO 10 INDEX =1,GRPCNT
      IF(GRPNMS(INDEX).EQ.NAME) TPOS=INDEX; GO TO 15
10    CONTINUE
      OUTPUT' NO SUCH GROUP'; GO TO 5
15    NRK=1
      CALL MAKEKEY(3,GRPNUM(TPOS),1,0,CSGPKEY)
      RKEY(1)= CSGPKEY
      CALL RDTCBUFF(CSGPKEY,900S)
20    CALL RDSQBUFF(NEXTKEY,30S)
      IF($GRPNM.NE.GRPNUM(TPOS)) GO TO 30
      NRK = NRK+1
      RKEY(NRK) = CSGPKEY
      IF($CODE.EQ.GRCODE.AND.$SBCOD.EQ.IVCODE)
     .                  GO TO 40
      IF($CODE.EQ.STCODE) GOTO 40
      GO TO 20
30    DO 35 INDEX = 1,NRK
      CSGPKEY = RKEY(INDEX)
      CALL CSGPDEL(CSGPKEY,900S)
      CALL RSPDEL(CSGPKEY,900S)
35    CONTINUE
      GRPNMS(TPOS) = '..DELETED..'
      GRPNUM(TPOS) = 0
      GO TO 99
40    OUTPUT ' ALL SETS AND INVERT ITMS MUST BE DELETED FIRST'
      OUTPUT ' GROUP CANNOT BE DELETED'
99    RETURN
900   STOP ' UNABLE TO LOCATED GROUP INTCSGP FILE - DELGRP -'
      END
      SUBROUTINE MODGRP
      INCLUDE ERSP_IN02
      INCLUDE ERSP_IN01
      INTEGER GPRIME
      INCLUDE ERSP_IN04
10    CONTINUE
      CALL PNAME('GROUP NAME',99S)
      DO 20 INDEX = 1,GRPCNT
      IF(GRPNMS(INDEX).EQ.NAME)$GRPNM=GRPNUM(INDEX);GO TO 30
20    CONTINUE
      OUTPUT 'GROUP DOES NOT EXIST'
      GO TO 10
30    CALL MAKEKEY(3,$GRPNM,1,0,CSGPKEY)
      CALL RDTCBUFF(CSGPKEY,900S)
      CALL RDRSP(CSGPKEY,901S)
35    CALL PNAME('AREA NAME',50S)
      DO 40 INDEX=1,AREACNT
      IF(AREANMS(INDEX).EQ.NAME)$AREA=ARANUM(INDEX);GO TO 50
40    CONTINUE
      OUTPUT 'AREA DOES NOT EXIST ' ;GO TO 35
50    CALL MAKEKEY(2,$AREA,1,0,TEMPKEY)
      CALL RDTCTEMP(TEMPKEY,902S)
60    CALL PRMTV('LOW PAGE OF RANGE',TEMPBUF(5),70S)
      $GPGMIN=VAL
70    CALL PRMTV('HIGH PAGE OF RANGE',TEMPBUF(5),80S)
      $GPGMAX=VAL
80    IF($GPGMIN.GT.$GPGMAX)OUTPUT 'HIGH > LOW PAGE';GO TO 60
      $PGPRM=GPRIME($GPGMIN,$GPGMAX)
      GTGPMX=$GPGMAX
      GTGPMN=$GPGMIN
      GTGPRV=$PGPRM
      ATGNUM=$AREA
      CALL WDCSGP(CSGPKEY,701S)
      CALL WDRSP(CSGPKEY,700S)
99    RETURN
700   STOP 'UNABLE TO WRITE RSP -MODGRP- '
701   STOP 'UNABLE TO WRITE TCSGP -MODGRP- '
900   STOP 'UNABLE TO READ TCSGP FILE -MODGRP-'
901   STOP 'UNABLE TO READ RSPROG FILE -MODGRP- '
902   STOP 'UNABLE TO READ TCSGP FILE -MODGRP- '
      END
      SUBROUTINE NIMP
      INCLUDE ERSP_IN02
      INCLUDE ERSP_IN04
      INCLUDE ERSP_IN01
      ENTRY ADDINV
      ENTRY MODINV
      OUTPUT 'UNIMPLEMENTED FEATURE'
      RETURN
      END
      SUBROUTINE DELITM
      INCLUDE ERSP_IN04
      INCLUDE ERSP_IN01
      INCLUDE ERSP_IN02
      INTEGER GRPNO,FINC
      CALL FINDGRP(GRPNO,CSGPKEY,10S)
      OUTPUT ' NO SUCH GROUP'
      GO TO 99
10    CALL FINDITM(GRPNO,FINC,CSGPKEY,20S)
      OUTPUT ' NO SUCH ITEM'
      GO TO 99
20    IF($CONT.NE.0) OUTPUT ' CANNOT DELETE A CONTROL ITEM';
     . GO TO 99
      IF($INVRT.EQ.1)  GO TO 30
      CALL CSGPDEL(CSGPKEY,900S)
      CALL RSPDEL(CSGPKEY,901S)
      GO TO 99
30    OUTPUT ' ITEM IS INVERTED'
      OUTPUT ' INVERT GROUP MUST BE DELETED FIRST'
      GO TO 99
99    RETURN
900   STOP ' ERROR DELETING TCSGP--DELITM--'
901   STOP ' ERROR DELETING  RSP--DELITM--'
      ENTRY MODITM
      CALL FINDGRP(GRPNO,CSGPKEY,40S)
      OUTPUT ' NO SUCH GROUP'
      GO TO 99
40    CALL FINDITM(GRPNO,FINC,CSGPKEY,50S)
      OUTPUT ' NO SUCH ITEM'
      GO TO 99
50    IF($INVRT.EQ.1)  OUTPUT ' CANNOT MODIFY INVERTED ITEM';
     .       GO TO 99
      CALL PRMTV('ENTER NEW FIELD SIZE IN BYTES',31,60S)
      IEXPND=-1
      ITGSIZ=VAL
      $ISIZE=VAL
      BUFFER($INSIZ+14)=0
C     SET PICTURE OFF/NONE
      CALL WDRSP(CSGPKEY,902S)
      CALL WDCSGP(CSGPKEY,903S)
      GO TO 99
902   STOP ' UPDATE ERROR RSP--MODITM--'
903   STOP ' UPDATE ERROR CSGP--MODITM--'
      ENTRY ADDITM
      CALL FINDGRP(GRPNO,CSGPKEY,60S)
      OUTPUT ' NO SUCH GROUP'
      GO TO 99
60    ITGARA=$AREA
      CALL FINDITM(GRPNO,FINC,CSGPKEY,70S)
      RSPCODE=3
      $CODE=GRCODE;$SBCOD=ITCODE
      RSPSORT=GRPNO
      ICNTRL=$CONT=0
      $GRNUM=GRPNO
C     DEFAULT BINARY
      ITYPCD=$ITYPE=4
      $ISIZE=ITGSIZ=4
      INVGRP=$INVRT=0
      ITGPOS=$FINC=FINC
      ISCPOS=ISCSIZ=0
      ITGARA=$AREA
55    CALL PRMT('TYPE (1-ALPHA,2-NUMERIC,3-ALPHABETIC,4-BINARY)',
     .                 4,55S)
      ITYPCD=$ITYPE=RESP
      IF(ITYPCD.EQ.4) GO TO 57
56    CALL PRMTV(' SIZE IN BYTES',31,56S)
      $ISIZE=ITGSIZ=VAL
57    CONTINUE
      $INSIZ=31;CALL ATOI(NAME,BUFFER(14));BUFFER(14+31)=0
      CALL WDCSGP(CSGPKEY,903S)
      GO TO 99
70    OUTPUT ' ITEM EXISTS '
      GO TO 99
      END
      SUBROUTINE FINDITM(GRPNO,FINC,CSGPKEY,FOUND)
      INCLUDE ERSP_IN04
      INCLUDE ERSP_IN01
      INCLUDE ERSP_IN02
      INTEGER GRPNO,FINC,FOUND
      CHARACTER*31 CNAME
5     CALL PNAME(' ITEM NAME',5S)
      CALL MAKEKEY(3,GRPNO,1,0,CSGPKEY)
      CALL RDTCBUFF(CSGPKEY,900S)
10    CALL RDSQBUFF(NEXTKEY,900S)
      IF(GRPNO.NE.$GRNUM) GO TO 30
      IF($SBCOD.LT.ITCODE) GO TO 10
      IF($SBCOD.GT.ITCODE) GO TO 30
      FINC=$FINC
      IF(CNAME.EQ.NAME) GO TO 20
      FINC=$FINC+$ISIZE
      GO TO 10
30    CALL MAKEKEY(3,GRPNO,5,FINC,CSGPKEY)
      RETURN
20    INQUIRE(TCSGP,KEY=CSGPKEY)
      CALL RDRSP(CSGPKEY,900S)
      RETURN FOUND
900   STOP ' READ ERROR --FINDITM--'
      ENTRY FINDGRP(GRPNO,CSGPKEY,FOUND)
      GRPNO=0
40    CALL PNAME(' GROUP NAME',40S)
      DO 50 INDEX=1,GRPCNT
      IF(GRPNMS(INDEX).EQ.NAME) GRPNO=GRPNUM(INDEX);
     .       GO TO 60
50    CONTINUE
             RETURN
60    CALL MAKEKEY(3,GRPNO,1,0,CSGPKEY)
      RETURN FOUND
      END
      SUBROUTINE DELINV
      INCLUDE ERSP_IN04
      INCLUDE ERSP_IN01
      INCLUDE ERSP_IN02
      INTEGER IGRPNO,GRPNO,FINC
      CHARACTER*31 CNAME
10    CALL PRMTV(' INVERT GROUP NO',1000,10S)
      IGRPNO=VAL
      CALL FINDGRP(GRPNO,CSGPKEY,20S)
      OUTPUT ' NO SUCH GROUP'
      GO TO 99
20    CALL FINDITM(GRPNO,FINC,CSGPKEY,30S)
      OUTPUT ' NO SUCH ITEM'
      GO TO 99
30    CALL MAKEKEY(3,GRPNO,7,IGRPNO,TEMPKEY)
      CALL RDTCTEMP(TEMPKEY,901S)
      $INVRT=INVERT=0
      CALL WDRSP(CSGPKEY,902S)
      CALL WDCSGP(CSGPKEY,903S)
      CALL CSGPDEL(TEMPKEY,904S)
      CALL MAKEKEY(3,IGRPNO,1,0,CSGPKEY)
      CALL RDTCBUFF(CSGPKEY,904S)
40    CONTINUE
      IF(IGRPNO.NE.$GRNUM)GOTO 99
      CALL CSGPDEL(CSGPKEY,904S)
      CALL RSPDEL(CSGPKEY,904S)
      CALL RDSQBUFF(NEXTKEY,904S)
      INQUIRE(TCSGP,KEY=CSGPKEY)
      GO TO 40
99    RETURN
902   STOP ' ERROR RSP UPDATE --DELINV--'
903   STOP ' ERROR CSGP UPDATE --DELINV--'
901   OUTPUT ' INCORRECT INVERT GROUP'
      GO TO 99
      END
      SUBROUTINE PICSCAN($OCCRS,$ISIZE,$TYPE,$PSIZE,$PICTR,$SIGN,
     @$DLEN)
*A COPY OF THE SUBROUTINE OCCURS W/FEW MODIFICATIONS -- JML
      IMPLICIT LOGICAL(A-Z,$)
      INTEGER CHAR9/ZF9000000/,CHARA/ZC1000000/,CHARX/ZE7000000/
      INTEGER CHAR0/ZF0000000/,CHARLB/Z4D000000/,CHARRB/Z5D000000/
      INTEGER CHARS/ZE2000000/
      INTEGER $OCCRS,$ISIZE,$TYPE,$PSIZE,$PICTR(30),$INDEX,$SIZE
     .,$MXPIC,$BSIZE,$TSIZE,$SIGN,$DLEN
*
*
*        FIRST TAKE CARE OF BINARY AND FLOATING ITEMS
*
*
      IF($TYPE.EQ.4)$OCCRS=$ISIZE/4;$ISIZE=4;RETURN
      IF($TYPE.EQ.5)$OCCRS=$ISIZE/4;$ISIZE=4;RETURN
      IF($TYPE.EQ.6)$OCCRS=$ISIZE/8;$ISIZE=8;RETURN
*
*
*            FIND OUT HOW BIG THE PICTURE SAYS THE ITEM IS
*
*
      $SIZE = 0
      $SIGN = 0
      IF($PSIZE.EQ.0)GO TO 999
      $INDEX = 0
99    CONTINUE
      $INDEX = $INDEX + 1
      IF($INDEX.GT.$PSIZE)GO TO 990
         IF($PICTR($INDEX).EQ.CHAR9.OR.
     .      $PICTR($INDEX).EQ.CHARA.OR.
     .      $PICTR($INDEX).EQ.CHARX)$SIZE=$SIZE+1
      IF($PICTR($INDEX).EQ.CHARS)$SIGN=1
      IF($PICTR($INDEX).NE.CHARLB)GO TO 99
      $BSIZE = 0
      $SIZE = $SIZE - 1
97    CONTINUE
      $INDEX = $INDEX + 1
      IF($PICTR($INDEX).EQ.CHARRB)GO TO 98
      IF($PICTR($INDEX).LE.CHAR9.AND.
     .   $PICTR($INDEX).GE.CHAR0)
     .$BSIZE = $BSIZE*10+ISL($PICTR($INDEX)-CHAR0,-24)
      GO TO 97
98    CONTINUE
      $SIZE       = $SIZE + $BSIZE
      GO TO 99
990   CONTINUE
      $DLEN=$SIZE
      IF($SIZE.EQ.0)GO TO 999
      IF($TYPE.NE.7)GO TO 997
      $TSIZE = $SIZE
      IF(MOD($SIZE,2).EQ.0)$SIZE=$SIZE+2;GO TO 996
      IF(MOD($SIZE,2).NE.0)$SIZE=$SIZE+1
      $SIZE = $SIZE / 2
996   $OCCRS = $ISIZE / $SIZE
      $ISIZE = $TSIZE
      RETURN
997   CONTINUE
      $OCCRS = $ISIZE / $SIZE
      $ISIZE = $SIZE
      RETURN
999   CONTINUE
      IF($TYPE.EQ.7)$MXPIC=16
      IF($TYPE.EQ.1.OR.
     .   $TYPE.EQ.3)$MXPIC=255
      IF($TYPE.EQ.0.OR.
     .   $TYPE.EQ.2)$MXPIC=31
      IF($ISIZE.LE.$MXPIC)$OCCRS=1;RETURN
9999  CONTINUE
      IF($MXPIC.LE.0)$OCCRS=1;RETURN
      IF(MOD($ISIZE,$MXPIC).NE.0)$MXPIC=$MXPIC-1;GO TO 9999
      $OCCRS = $ISIZE / $MXPIC
      IF($TYPE.NE.7)$ISIZE=$MXPIC;RETURN
      $ISIZE = $MXPIC * 2 - 1
      RETURN
      END
