C ********************************************************
C *  F U T I L I T Y - EXAMINES/MODIFIES DISK FILES OF   *
C *                    OF THE FOLLOWING PERSUASION:      *
C *                                                      *
C *                    1) - CONSECUTIVE
C *                    2) - KEYED                        *
C *                    3) - RANDOM                       *
C *                    4) - INDEXED RANDOM               *
C *                                                      *
C *  VALID COMMANDS:                                     *
C *                    1) - A[TTRIBUTES]                 *
C *                         CHANGES FILE ATTRIBUTES      *
C *                         WITHOUT PCL COPY             *
C *                    2) - D[ELETE]                     *
C *                         DELETES RECORDS              *
C *                    3) - E[XAMINE]                    *
C *                         EXAMINES CONTENTS OF RECS    *
C *                         DOWN TO THE WORD LEVEL.      *
C *                    4) - F[ILE]                       *
C *                         OPENS USE FILE, SETS ORG.    *
C *                    5) - I[NSERT]                     *
C *                         INSERTS RECORDS IN CONSEC AND*
C *                    6) - M[ODIFY]                     *
C *                         MODIFIES WORDS IN GIVEN RECS.*
C *                    7) - W[HATS]                      *
C *                         ADDS ANOTHER DIMENSION OF    *
C *                         MEANING TO NASTY SYSTEM HEX  *
C *                         ERROR CODES.                 *
C *                    8) - C[EASE]                      *
C *                         EXITS PROGRAM, RETURN TO TEL.*
C *  PROGRAM IS SELF-HELPING.                            *
C *  ALL COMMANDS PROMPT FOR OPTIONS.                    *
C *  NON-STANDARD ROUTINES USED:                         *
C *  ALL ROUTINES IN "GETPUT" -11 PACKAGE. OPENF,CLOSEF  *
C *  PUTR,GETSIZ,ERRSET,GETKEY,REWF, ETC.                *
C *  SOUT - SPECIAL STRING OUT KLUGE                     *
C *  QUICK - STRING IN WITH PROMPT KLUGE                 *
C *  ABORTSET - ABORT CONTROL                            *
C *  BRKRET - BREAK CONTROL                              *
C *  PURGE - I/O BUFFER PURGE                            *
C *  ALL ROUTINES IN "CHAIRMANIP" -11 PACKAGE            *
C *  "INDEXED RANDOM" FILE SCHEME WHERE A FILE IS AN     *
C *  DYNAMIC RANDOM OPENS AND CLOSES IN REALITY.         *
C *  THESE COULD BE DONE WITH THE MOTOROLA VERSION OF    *
C *  "GETPUT" WHICH ALLOWS FOR RANDOM OPENS WITH OPENF.*
C ********************************************************
C
      COMMON INBUF(2048),IOUTBUF(8192),IWRK1(20),IWRK2(20),IFNAME1(3)
      COMMON ICMND,IFLAG1,IORG,INUM,IFORMT(20),IFLAG2
C
      CALL ABORTSET(9999S,1)
      CALL SETUP
S     LI,2 X'40'
S     STW,2 8PROMPT
      IORG=999
      OUTPUT ' ';OUTPUT 'F U T I L I T Y  A00 HERE'
      CALL QUESTAR(' INSTRUCTIONS   ',16,5S,8S)
05    CALL HELPER
      GO TO 08
08    IDPTR=IDPTR+1
      GO TO 15
10    OUTPUT ' '
15    OUTPUT ' '
18    CALL OWNBRK(100S)
      CALL COMMAND
      GO TO(30,40,50,20,70,80,60,65),ICMND
20    CALL FILE
      GO TO 15
S30      LW,15    =X'200000'
S        CS,15    F:1
S        BE       35S
      OUTPUT 'NO FILE CURRENTLY OPEN--ENTER CHARACTERISTICS'
      OUTPUT 'OF FILE WHOSE ATTRIBUTES ARE TO BE MODIFIED BELOW:'
      CALL FILE
S        LW,15    =X'200000'
S        CS,15    F:1
S        BNE      15S
35    CALL ATTR
      GO TO 10
40    CALL DELETE
      GO TO 10
50    CALL EXAM
      GO TO 10
60    CALL INSERT
      GO TO 10
65    CALL MODIFY
      GO TO 10
80    CALL WHAT
100   GO TO 10
70    CALL CEASE
9999  OUTPUT ' '
      OUTPUT '!!! YOU DID A NO NO - TRY AGAIN'
      OUTPUT ' '
      GO TO 18
      END
      SUBROUTINE QUICK(I,N,X,NCR,K)
      DIMENSION I(20),N(20)
      ICOUN=(I(0)+3)/4
      WRITE (108,20) ICOUN,(I(J),J=1,ICOUN)
20    FORMAT(NA4,' ')
      READ(105,10) N
10    FORMAT(20A4)
S     LW,2 F:105+4
S     SLS,2 -17
S     AI,2 -1
S     STW,2 *NCR
      RETURN
      END
      SUBROUTINE SOUT(I,ICOUNT)
      DIMENSION I(20),N(80)
      DECODE (80,100,I) N
  100 FORMAT (80A1)
      WRITE (108,10) ICOUNT,(N(J),J=1,ICOUNT)
   10 FORMAT (1X,NA1)
      RETURN
      END
C*******************************************************
C            COMMAND - PARSE A COMMAND
C*******************************************************
C
C
C
      SUBROUTINE COMMAND
      COMMON INBUF(2048),IOUTBUF(8192),IWRK1(20),IWRK2(20),IFNAME1(3)
      COMMON ICMND,IFLAG1,IORG,INUM,IFORMT(20),IFLAG2
      DIMENSION ICMNDD(2)
      DATA ICMNDD/'ADEF','CWIM'/
      DATA IORGD /'CKIR'/
      DATA NCMNDS/8/
      IFLAG2=0
05    CALL QUICK(' COMMAND: ',IWRK1,30,NCR,0)
      IF(IWRK1(1).EQ.3HEND) CALL CEASE
      IF(NCR.EQ.0) CALL COMHELP; GO TO 05
      DO 10 I=1,NCMNDS
      IPOS=I
      ICMND=I
      ITEST=KOMP(IWRK1,1,ICMNDD,I,1)
      IF(ITEST.EQ.0) GO TO 20
10    CONTINUE
      CALL ERROR(1)
      GO TO 05
20    RETURN
      END
C
      SUBROUTINE ERROR(IERR)
      COMMON INBUF(2048),IOUTBUF(8192),IWRK1(20),IWRK2(20),IFNAME1(3)
      COMMON ICMND,IFLAG1,IORG,INUM,IFORMT(20),IFLAG2
      GO TO (2,4,6,8,10,12,14,16,18,20,28,30,40,50,60,70),IERR
02    OUTPUT 'SAY WHAT ?'
      RETURN
04    OUTPUT '!!! INVALID HEX FIELD DELIMITER(S) !!!'
      RETURN
06    OUTPUT '!!! INVALID FILE ORGANIZATION !!!'
      RETURN
08    OUTPUT '!!! FILE OPEN ERROR !!!'
      OUTPUT '!!! FILE NONEXISTANT, CONFLICTING ORG, OR BUSY !!!'
      RETURN
10    OUTPUT '!!! NONEXISTANT CODE !!!'
      RETURN
12    OUTPUT '!!!USE FILE NOT OPENED - USE "FILE" COMMAND !!!'
      RETURN
14    OUTPUT '!!! NONEXISTANT RECORD FOR SPECIFIED KEY !!!'
      RETURN
16    WRITE(108,25) INUM
25    FORMAT(1X,'!!! EOF ENCOUNTERED BEFORE RECORD ',I6,' !!!')
      RETURN
18    OUTPUT '!!! UN-GOOD FORMAT !!!'
      RETURN
20    OUTPUT '!!! REQUESTED WORD(S) NONEXISTANT !!!'
      RETURN
28    OUTPUT '!!! INVALID ACCESS METHOD - RETYPE'
      RETURN
30    OUTPUT '!!! MUST ACCESS A CONSEC. FILE CONSECUTIVELY !!!'
      RETURN
40    OUTPUT '!!! MUST ACCESS A KEYED FILE CONSEC. OR KEYED ONLY !!!'
      RETURN
50    OUTPUT '!!! MUST ACCESS A RANDOM FILE RANDOMLY !!!'
      RETURN
60    OUTPUT '!!! MUST ACCESS AN INDEXED RANDOM FILE IND RAND !!!'
      RETURN
70    OUTPUT '!!! RECORD LENGTH > 8192, PROGRAM MAX !!!'
      RETURN
      END
C          ROBIN - THIS ROUTINE PARSES AN INPUT STRING
C***********************************************************
C
C
C
      SUBROUTINE ROBIN(IRETRNEE,NUMCHRS,IERRFLG)
      COMMON INBUF(2048),IOUTBUF(8192),IWRK1(20),IWRK2(20),IFNAME1(3)
      COMMON ICMND,IFLAG1,IORG,INUM,IFORMT(20),IFLAG2
      COMMON /CBKEY/ KEYBUF(10)
      DIMENSION IRETRNEE(1)
      DATA ITABL/8Z7D7D7D7D/
C ROUTINE EXPECTS IWRK1 TO CONTAIN STRING TO BE PARSED
      CALL FIND(ITABL,1,IWRK1,1,NUMCHRS+1,CHAR,K2)
      IF(K2.EQ.0) GO TO 30
20    CALL FIND(ITABL,1,IWRK1,K2+1,NUMCHRS*2+3,CHAR,K3)
      IF(K3.EQ.0) CALL ERROR(2); IERRFLG=1; RETURN
      IL=K3-K2-1
      IKNT=1
      DO 22 I=K2+1,K2+1+IL-1,2
      CALL MOVE(IWRK1,I,IWRK,1,2)
      DECODE(2,25,IWRK),IWRK
25    FORMAT(Z2)
      CALL MOVE(IWRK,4,IRETRNEE,IKNT,1)
      IKNT=IKNT+1
22    CONTINUE
      IERRFLG=0
      NUMCHRS=IKNT-1
      RETURN
30    CALL MOVE(IWRK1,1,IRETRNEE,1,NUMCHRS)
      IERRFLG=0
40    RETURN
      END
C
      SUBROUTINE DUMPER(IDFLG,NCHRS,IKEY,IKEYLN,IBEGIN)
      COMMON INBUF(2048),IOUTBUF(8192),IWRK1(20),IWRK2(20),IFNAME1(3)
      COMMON ICMND,IFLAG1,IORG,INUM,IFORMT(20),IFLAG2
      DIMENSION IKEY(1)
      DIMENSION IDBUF(20)
      DIMENSION IBLK(10)
      DATA IBLK/10*4H    /
C
C IDFLG =1 - BCD DUMP WITH HEADING
C IDFLG =1 - HEX DUMP WITH HEADING
C IDFLG =3 - BCD WITHOUT HEADING
C IDFLG =4 - HEX WITHOUT HEADING
C
      IF(NCHRS.EQ.0) NCHRS=1
C KLUGE FOR GETSIZ2 RETURN OF 0 FOR BLANK RECORDS
      IDOT=4H....
      GO TO (10,10,28,100),IDFLG
10    OUTPUT ' '
      WRITE(108,15) NCHRS
      WRITE(108,17)
15    FORMAT(1X,'LENGTH (BYTES) = ',I4)
17    FORMAT(1X,8HKEY = X',' ')
02    ENCODE(IKEYLN*2,20,IWRK1,NC) (IKEY(J),J=1,IKEYLN/4+1)
20    FORMAT(8Z8)
      CALL SOUT(IWRK1,IKEYLN*2)
      WRITE(108,22)
22    FORMAT(1H',' ')
      DO 34 I=1,IKEYLN
      CALL CHRTYP(IKEY,I,ITYP,IVAL)
      IF(ITYP.EQ.5) CALL MOVE(IDOT,1,IKEY,I,1)
34    CONTINUE
      CALL SOUT('   BCD = ',9)
      CALL SOUT(IKEY,IKEYLN)
      OUTPUT ' '
30    GO TO (28,100,31,100),IDFLG
28    OUTPUT '=====  ================================================='
      OUTPUT ' '
31    IDCHR=NCHRS
      IPASS=NCHRS/40+1
      IF(MOD(NCHRS,40).EQ.0) IPASS=IPASS-1
      ILNCT=IBEGIN
      ILPTR=1
      IEND=(IBEGIN+NCHRS-1)/4+1
      ENCODE(NCHRS/4+NCHRS,35,IOUTBUF,NC)   (INBUF(J),J=IBEGIN,IEND)
35    FORMAT(2048(A4,1X))
      DO 38 I=1,IPASS
32    WRITE(108,26) ILPTR
26    FORMAT(2X,I4,2X,' ')
      DO 37 II=1,20
37    IDBUF(II)=4H
      IF(I.NE.IPASS) IACT=49
      IF(I.EQ.IPASS) IACT=IDCHR/4+IDCHR
      CALL MOVE(IOUTBUF,ILNCT,IDBUF,1,IACT)
      CALL SOUT(IDBUF,IACT)
      IDCHR=IDCHR-40
       ILPTR=ILPTR+10
      ILNCT=ILNCT+50
38    CONTINUE
40    GO TO 147
100   OUTPUT '=====  ===================================================
     *=='
105   OUTPUT ' '
      IEND=(IBEGIN+NCHRS-1)/4+1
      ENCODE((NCHRS*2)/8+(NCHRS*2),110,IOUTBUF,NC)   (INBUF(J),J=IBEGIN
     *,IEND)
110   FORMAT(512(Z8,1X))
      IDCHR=NCHRS
      ISP=2
      ILNCT=IBEGIN
      ILPTR=1
      IPASS=NCHRS*2/32+1
      IF(MOD(NCHRS,16).EQ.0) IPASS=IPASS-1
112   WRITE(108,26) ILPTR
      DO 113 II=1,20
113   IDBUF(II)=4H
      IF(I.NE.IPASS) IACT=35; INC=15
      IF(I.EQ.IPASS) IACT=IDCHR/4+IDCHR*2; INC=IDCHR-1
      CALL MOVE(IOUTBUF,ILNCT,IDBUF,1,IACT)
      IDPTR=1
      ICOUN=((IACT+3)/4)+1
      IDBUF(ICOUN)=4H
      CALL SOUT(IDBUF,ICOUN*4)
      DO 138 JJ=IBEGIN+(ILPTR-1)*4,IBEGIN+(ILPTR-1)*4+INC
      CALL CHRTYP(INBUF,JJ,ITYP,IVAL)
      IF(ITYP.EQ.5) CALL MOVE(IDOT,1,IDBUF,IDPTR,1)
      IF(ITYP.NE.5) CALL MOVE(INBUF,JJ,IDBUF,IDPTR,1)
      IDPTR=IDPTR+1
138   CONTINUE
      IF(I.EQ.IPASS) ISP=35-IACT+2
      CALL SOUT('=>  ',4)
      CALL SOUT(IDBUF,INC+1)
      IDCHR=IDCHR-16
      ILNCT=ILNCT+36
      ILPTR=ILPTR+4
145   CONTINUE
147   CONTINUE
C INSERT CALL MODIFY HERE LATER
      OUTPUT ' '
140   RETURN
      END
C*********************************************************
C            GETAKEY - GETS A KEYED RECORD
C*********************************************************
C
C
C
      SUBROUTINE GETAKEY(IERR,KLN,ISIZ)
      COMMON INBUF(2048),IOUTBUF(8192),IWRK1(20),IWRK2(20),IFNAME1(3)
      COMMON ICMND,IFLAG1,IORG,INUM,IFORMT(20),IFLAG2
      COMMON /CBKEY/KEYBUF(10)
44    OUTPUT 'KEYLENGTH:  '; INPUT KLN
      IF(KLN.EQ.0) RETURN
      CALL QUICK(' KEY: ',IWRK1,80,NCR,0)
      IF(NCR.EQ.0) GO TO 100
      CALL ROBIN(IWRK2,KLN,IERR)
      IF(IERR.EQ.1) GO TO 44
      CALL MOVE(IWRK2,1,KEYBUF,1,KLN)
      CALL ERRSET2(IERR,88S,88S,IDCB)
      CALL GETR(1,INBUF,2048,IWRK2,KLN)
      CALL GETSIZ2(1,ISIZ)
      IERR=0
      GO TO 45
88    CALL ERROR(7)
      IERR=1
100   CALL GETR(1,INBUF,2048)
      CALL GETKEY(1,IWRK2,NCR)
      CALL GETSIZ2(1,ISIZ)
      KLN = NCR
      CALL MOVE(IWRK2,1,KEYBUF,1,KLN)
      RETURN
      END
C
      SUBROUTINE FORMGET(IFM)
      COMMON INBUF(2048),IOUTBUF(8192),IWRK1(20),IWRK2(20),IFNAME1(3)
      COMMON ICMND,IFLAG1,IORG,INUM,IFORMT(20),IFLAG2
      DATA IFORM/'BHO '/
      IF(IFLAG2.EQ.0) GO TO 20
      GO TO 40
20    CALL QUICK(' FORMAT: ',IWRK1,6,NCR,0)
      IF(NCR.EQ.0) CALL FORMHELP; GO TO 20
      IFLAG2=1
      DO 30 I=1,4
      IFM=I
      ITEST=KOMP(IFORM,I,IWRK1,1,1)
      IF(ITEST.EQ.0) GO TO 40
30    CONTINUE
      CALL ERROR(9)
      CALL FORMHELP
      GO TO 20
40    RETURN
      END
C
      SUBROUTINE FDUMP(NBYTES)
      COMMON INBUF(2048),IOUTBUF(8192),IWRK1(20),IWRK2(20),IFNAME1(3)
      COMMON ICMND,IFLAG1,IORG,INUM,IFORMT(20),IFLAG2
      OUTPUT 'ENTER FORTRAN FORMAT:  '
      READ(105,10) IFORMT
10    FORMAT(20A4)
      WRITE(108,IFORMT) (INBUF(J),J=1,NBYTES/4)
      RETURN
      END
C
      SUBROUTINE OWNBRK(*)
      COMMON INBUF(2048),IOUTBUF(8192),IWRK1(20),IWRK2(20),IFNAME1(3)
      COMMON ICMND,IFLAG1,IORG,INUM,IFORMT(20),IFLAG2
      COMMON /CBKEY/ KEYBUF(10)
      RETURN
      ENTRY SETUP
S10   LI,2     20S
S     AW,2   =8Z0E000000
S     STW,2    FPT
S     CAL1,8   FPT
      RETURN
S20   LCI  2
S     PLM,2 *0
S     CI,3 -1
S     BE $+3
S     LI,2 -18
S     B $+2
S     LI,2 -19
S     MSP,2 *0
      RETURN 1
      END
C
      COMMON INBUF(2048),IOUTBUF(8192),IWRK1(20),IWRK2(20),IFNAME1(3)
      COMMON ICMND,IFLAG1,IORG,INUM,IFORMT(20),IFLAG2
      COMMON /CBKEY/ KEYBUF(10)
      CALL SOUT(ISTRNG,INC)
      CALL SOUT(' - Y/N: ',8)
      READ(105,10) IWRK9
10    FORMAT(A4)
      IF(IWRK9.EQ.1HY.OR.IWRK9.EQ.3HYES) RETURN IBRY
C ANYTHING OTHER THAN Y/YES = NO
      RETURN IBRN
      END
C
      SUBROUTINE GETSIZ2(IDM1,IDM2)
      COMMON INBUF(2048),IOUTBUF(8192),IWRK1(20),IWRK2(20),IFNAME1(3)
      COMMON ICMND,IFLAG1,IORG,INUM,IFORMT(20),IFLAG2
      COMMON /CBKEY/ KEYBUF(10)
      CALL GETSIZ(IDM1,IDM2)
      IF(IDM2.GT.8192) CALL ERROR(16); CALL EXIT
      RETURN
      END
C
      SUBROUTINE ERRSET2(IDUM1,IDB1,IDB2,IDUM2)
      COMMON INBUF(2048),IOUTBUF(8192),IWRK1(20),IWRK2(20),IFNAME1(3)
      COMMON ICMND,IFLAG1,IORG,INUM,IFORMT(20),IFLAG2
      COMMON /CBKEY/ KEYBUF(10)
      CALL ERRSET(IDUM1,10S,10S,IDUM2,IMINR)
      RETURN
10    IF(IDUM1.EQ.6.OR.IDUM1.EQ.66.OR.IDUM1.EQ.67) GO TO 20
      WRITE(108,15) IDUM1,IMINR
15    FORMAT(1X,'MAJ ERR CODE = ',Z2,5X,'MIN ERR CODE = ',Z2)
20    RETURN IDB1
      END
