PROGRAM KEYPUNCH
C
C     KEYPUNCH EMULATING PROGRAM
C
C     G. CARNAHAN & D. LAMB
C     OCT 21, 1981
C
C     THIS PROGRAM SEEKS TO EMULATE A KEYPUNCH MACHINE BY
C     BY ACCEPTING DATA A CHARACTER AT A TIME. THE CHARACTER
C     IS TESTED FOR VALIDITY AGAINST A PROGRAM CARD, PREVIOUSLY
C     INPUTED BY THE USER. KEYPUNCH ALSO HAS EDIT CAPABILITIES,
C     INCLUDING COLUMN INSERTION AND DELETION, AND A VERIFY
C     MODE.
C
C     THE MAINLINE OPENS TWO FILES. FILE 1 IS THE USER'S
C     INPUT FILE. IF NO FILE IS INPUTED, IT IS OPENED 'NEW'.
C     FILE 11 IS THE WORK FILE. IT IS OPENED AS A FIXED
C     LENGTH, INDEXED, KEYED FILE, WITH THE KEY BEING COLUMNS
C     83 THRU 88. COLUMNS 83 THRU 86 CONTAIN THE SEQUENTIAL
C     RECORD NUMBER, WHILE COLUMNS 87 AND 88 ALLOW SEQUENCING
C     OF INSERTED RECORDS.
C
C     THE MAINLINE CONTROLS THE MODE, OR ENVIRONMENT OF THE
C     EMULATOR. DATA CAN BE ENTERED IN 'DATA ENTRY' MODE,
C     'ALTER DATA' MODE, 'VERIFY DATA' MODE, OR 'INSERT DATA'
C     MODE. MAIN MODE IS USED FOR COMMAND ENTRY. DATA IS 
C     PROCESSED IN THE SUBROUTINE 'EMULATOR', BUT IT IS HANDLED 
C     DIFFERENTLY, ACCORDING TO THE MODE.
C
C     VALID INPUT COMMANDS IN MAIN MODE ARE:
C
C           A[N:N]     -     ALTER DATA OVER A RANGE
C           DL[N:N]    -     DELETE LINES
C           DC[N:N]    -     DELETE COLUMNS OVER A RANGE 
C           FSTRING    -     FIND A STRING
C           IL[START]  -     INSERT LINES AT A STARTING POINT
C           IC[N:N]    -     INSERT COLUMNS OVER A RANGE
C           P[N:N]     -     PRINT LINES OVER A RANGE
C           S[N:N]     -     SUBSTITUTE COLUMNS OVER A RANGE
C           V[START]   -     VERIFY DATA AT STARTING RECORD
C           W          -     SAVE WORLD
C
C     CONTROL KEYS ARE ALSO USED AS INPUT COMMANDS. FOR LIST
C     OF CONTROL KEY FUNCTIONS, SEE SUBROUTINE 'EMULATOR'.
C
C****************************************************************
C
C     KEYPUNCH COMMON
C
      CHARACTER*96 BUFFER,SAVE
      CHARACTER*80 MASK,MASKA,MASKB
      CHARACTER*6  LKEY,HKEY,CKEY,TKEY,PKEY
      CHARACTER*4  PROG
      CHARACTER*1  FIELD
C
      INTEGER*4    SK1,IRCNT,ICOL,LCOL
C
      LOGICAL*1    MMODE,AMODE,EMODE,VMODE,IMODE
C
      COMMON/COM1/BUFFER,SAVE,MASK,MASKA,MASKB,PROG,FIELD
      COMMON/COM2/LKEY,HKEY,TKEY
      COMMON/COM3/SK1,IRCNT,ICOL,LCOL
      COMMON/COM4/MMODE,AMODE,EMODE,VMODE,IMODE
C
      EQUIVALENCE (BUFFER(83:88),CKEY(1:6)),(BUFFER(89:94),PKEY(1:6))
C
C*****************************************************************
C
C     LOCAL DECLARATIONS
C
      CHARACTER*80 INPUT, STRING, FSTRING
      CHARACTER*16 FILENAME
      CHARACTER*14 HELP
      CHARACTER*6  EKEY, LUN
      CHARACTER*1  CHAR, STOP, CR, ESC, BS, CTRLA, CTRLB
      CHARACTER*1  CTRLV, CTRLP, CTRLN
      INTEGER*4    ZERO
      INTEGER*2    MOVEUP,DEV,WIDTH,PAGE
      LOGICAL*1    NEW, VT100, HP2621, WORLD, NUMBER
      DATA SK1/11/, IRCNT/0/, ICOL/0/, ZERO/0/
      DATA NEW/.FALSE./, CKEY/'000000'/, STOP/Z1A/
      DATA CR/Z0D/, ESC/Z1B/, BS/Z08/, PKEY/'000000'/
      DATA VT100/.FALSE./, HP2621/.FALSE./, MOVEUP/Z411B/
      DATA CTRLA,CTRLB,CTRLP,CTRLV,CTRLN/Z1,Z2,Z10,Z16,ZE/
      DATA HELP/'HELP KEYPUNCH '/, NUMBER/.FALSE./
      DATA LUN/'FOR001'/, IWORLD/0/
C
C***************************************************************
C
C     GET THE FILE NAME AND PARSE OFF ANY VERSION SPEC FOR LATER USE
C
      ISTAT = SYS$TRNLOG(LUN,IFLEN,FILENAME,,,)
      JFLEN = INDEX(FILENAME,';') - 1
      IF(JFLEN.LE.0) JFLEN = IFLEN
C
C     OPEN FILE 1 AS 'OLD'. IF ERROR, OPEN AS 'NEW'
C
      OPEN(UNIT=1,NAME=FILENAME(1:IFLEN),TYPE='OLD',ERR=10)
      GO TO 20
   10 OPEN(UNIT=1,NAME=FILENAME(1:IFLEN),TYPE='NEW')
      NEW = .TRUE.
C
C     OPEN THE WORK FILE. IF UNIT 1 IS OLD, LOAD DATA 
C     INTO THE WORK FILE. INITIALIZE THE KEYS AS FOLLOWS:
C              LKEY = LOWEST RECORD IN FILE
C              HKEY = HIGHEST RECORD IN FILE
C              TKEY = TARGET KEY WHEN LOOPING THROUGH DATA
C              CKEY = CURRENT KEY - EQUIVALENCED TO BUFFER
C              PKEY = PREVIOUS RECORD POINTER - EQUIV. TO BUFFER
C
   20 OPEN(UNIT=SK1,TYPE='NEW',FORM='UNFORMATTED',
     1     ORGANIZATION='INDEXED',ACCESS='KEYED',
     2     RECORDSIZE=24,RECORDTYPE='FIXED',
     3     KEY=(83:88:CHARACTER))
C
      IF(.NOT.NEW) THEN
         DO WHILE (.TRUE.)
         READ(1,1000,END=50) ICOL, BUFFER(1:ICOL)
         IRCNT = IRCNT + 1
         PKEY = CKEY
         CALL CFILL(BUFFER,ICOL+1,80,' ')
         WRITE(BUFFER(81:88),1001) ICOL,IRCNT,ZERO
         WRITE(SK1) BUFFER
         END DO
      END IF
C
   50 LKEY = '000100'
      HKEY = CKEY
      TKEY = '000000'
C
C     IF WE ARE RENUMBERING, DELETE THE NEWEST FILE 1, THEN SKIP TO 100
C
      IF(NUMBER) THEN
         CLOSE(UNIT=1,DISPOSE='DELETE')
         OPEN(UNIT=1,NAME=FILENAME(1:IFLEN),TYPE='UNKNOWN')
         GO TO 100
      END IF
C
C     FIND OUT THE TERMINAL TYPE. 
C
      ISTAT = LIB$SCREEN_INFO(IDUMY,DEV,WIDTH,PAGE)
      IF(DEV.EQ.64.OR.DEV.EQ.96) VT100 = .TRUE.
      IF(DEV.EQ.65) HP2621 = .TRUE.
      IF(DEV.EQ.65) OPEN(UNIT=65,FORM='UNFORMATTED',TYPE='OLD')
C
C     INITIALIZE THE PROGRAM MASK TO ALPHA
C
      MASK(1:1) = 'A'
      CALL CFILL(MASK,2,80,'+')
      MASKA = MASK
      MASKB = MASK
      CALL CONTROL(CTRLN)
C
C     THIS CODE WILL ONLY BE USED IF ALL LINES IN THE FILE
C     HAVE BEEN DELETED. WE GET HERE FROM AN ERROR READ
C     IN THE DELETE LINES CODE.
C
      DO WHILE (.FALSE.)
   75    PRINT *,'    All lines deleted - file is empty '
         LKEY = '000100'
         CKEY = '000000'
         HKEY = CKEY
         TKEY = CKEY
         IRCNT= 0
         CALL CFILL(SAVE,1,94,' ')
      END DO
C
C     HERE WE GO! SET MAIN MODE ON, ALL OTHER MODES OFF. THEN
C     PRINT CURRENT LINE NUMBER, PROMPT FOR COMMAND.
C
  100 MMODE = .TRUE.
      AMODE = .FALSE.
      EMODE = .FALSE.
      IMODE = .FALSE.
      VMODE = .FALSE.
      WORLD = .FALSE.
      NUMBER= .FALSE.
C
C     PRINT PROMPT CHARACTERS. PARSE THE LINE NUMBER FIRST.
C
      IBCK = 1
      IF(CKEY(1:1).EQ.'0') IBCK = 2
      IF(CKEY(1:2).EQ.'00') IBCK = 3
      IF(CKEY(1:3).EQ.'000') IBCK = 4
      PRINT 1002, CKEY(IBCK:6)
      CALL GETSTR(INPUT,LEN)
      CHAR = INPUT(1:1)
      IF (CHAR.EQ.STOP) THEN
          IF(HKEY.LT.LKEY) THEN
            CLOSE(UNIT=SK1,DISPOSE='DELETE')
            CLOSE(UNIT=1,DISPOSE='DELETE')
            CALL EXIT
          ELSE
            IF(NEW) THEN
               INPUT(1:1) = 'Y'
               GO TO 950
            END IF
            GO TO 900
          END IF
      END IF
C
C     PROCESS THE COMMAND
C
C     DISPLAY COMMANDS ARE 'P', CR, ESC
C     
      IF(CHAR.EQ.'P') THEN
         CALL RANGE(INPUT(2:LEN))
         CALL CFILL(BUFFER,ICOL+1,80,' ')
         IF(VT100) ISTAT=LIB$DOWN_SCROLL()
         IF(HP2621) WRITE(65) MOVEUP
         PRINT 1004, BUFFER(1:MAX0(20,ICOL))
         DO WHILE (CKEY.LT.TKEY)
            READ(SK1) BUFFER
            READ(BUFFER(81:82),1001) ICOL
            PRINT 1004, BUFFER(1:MAX0(20,ICOL))
         END DO
         GO TO 100
      END IF
C
      IF(CHAR.EQ.CR) THEN
        IF(CKEY.GE.HKEY) THEN
            PRINT *,'   No such line '
            GO TO 100
         END IF
         READ(SK1) BUFFER
         READ(BUFFER(81:82),1001) ICOL
         CALL CFILL(BUFFER,ICOL+1,80,' ')
         IF(VT100) ISTAT = LIB$DOWN_SCROLL()
         IF(HP2621) WRITE(65) MOVEUP
         PRINT 1004, BUFFER(1:MAX0(ICOL,20))
         GO TO 100
      END IF
C
      IF(CHAR.EQ.ESC) THEN
         IF(CKEY.LE.LKEY) THEN
            PRINT *, '   No such line  '
            GO TO 100
         END IF
         READ(SK1,KEY=PKEY) BUFFER
         READ(BUFFER(81:82),1001) ICOL
         CALL CFILL(BUFFER,ICOL+1,80,' ')
         PRINT 1007, (BS,I=1,13-IBCK)
         PRINT 1007, BUFFER(1:MAX0(ICOL,20))
         GO TO 100
      END IF
C
C     DATA ENTRY MODE
C
      IF(CHAR.EQ.'E') THEN
         EMODE = .TRUE.
         MMODE = .FALSE.
         IF(HKEY.EQ.'000000') THEN
            SAVE = ' '
            LCOL = 80
            SAVE(83:88) = HKEY
         ELSE
            CALL RANGE(HKEY)
            SAVE = BUFFER
            LCOL = ICOL
         END IF
         IF(HKEY.NE.'000000') THEN
            PRINT *,'      Last line entered: '
            PRINT *, SAVE(1:LCOL)
         END IF
         PRINT *,'      Enter data... '
         CALL EMULATOR
         GO TO 100
      END IF
C
C     ALTER LINE(S) MODE
C
      IF(CHAR.EQ.'A') THEN
         AMODE = .TRUE.
         MMODE = .FALSE.
         IF(HKEY.EQ.'000000') THEN
            PRINT *,' No such line...'
            GO TO 100
         ELSE
            CALL RANGE(INPUT(2:LEN))
            SAVE = BUFFER
            LCOL = ICOL
            IF(MMODE) GO TO 100
         END IF
         PRINT *,'      Alter data... '
         CALL EMULATOR
         GO TO 100
      END IF
C
C     VERIFY DATA MODE
C     
      IF(CHAR.EQ.'V') THEN
         VMODE = .TRUE.
         MMODE = .FALSE.
         IF(HKEY.EQ.'000000') THEN
            PRINT *,'  No such line... '
            GO TO 100
         END IF
         CALL RANGE(INPUT(2:LEN))
         TKEY = HKEY
         IF(MMODE) GO TO 100
         PRINT *,'      Verify data. Begin at line ',CKEY
         CALL EMULATOR
         GO TO 100
      END IF
C
C     INSERT LINES OR COLUMNS
C
      IF(CHAR.EQ.'I') THEN
         CHAR = INPUT(2:2)
         IF(CHAR.EQ.'L') THEN
            IMODE = .TRUE.
            MMODE = .FALSE.
            CALL RANGE(INPUT(3:LEN))
            IF(MMODE) GO TO 100
            IF(TKEY.LT.LKEY) THEN
               SAVE = BUFFER
               LCOL = ICOL
            ELSE
               IF(TKEY.EQ.HKEY) THEN
                  PRINT *,TKEY,' is the last line. Use Data Entry mode.'
                  GO TO 100
               END IF
               READ(SK1) SAVE
               READ(SAVE(81:82),1001) LCOL
            END IF
            PRINT *,'      Insert data... '
            CALL EMULATOR
            GO TO 100
         END IF
         IF(CHAR.EQ.'C') THEN
            PRINT 1004,' Enter number of columns to be inserted: '
            CALL GETSTR(INPUT,LEN)
            CALL NUMPARSE(INPUT(1:LEN),NC,I)
            PRINT 1004,' Insert columns before which column? '
            CALL GETSTR(INPUT,LEN)
            CALL NUMPARSE(INPUT(1:LEN),IC,I)
            PRINT 1004,' Enter range: '
            CALL GETSTR(INPUT,LEN)
            CALL RANGE(INPUT(1:LEN))
            L = IC + NC
            BUFFER(L:80) = BUFFER(IC:ICOL)
            CALL CFILL(BUFFER,IC,L-1,' ')
            ICOL = ICOL + NC
            WRITE(BUFFER(81:82),1001) ICOL
            REWRITE(SK1) BUFFER
            PRINT 1004, BUFFER(1:ICOL)
            DO WHILE (CKEY.LT.TKEY)
               READ(SK1) BUFFER
               READ(BUFFER(81:82),1001) ICOL
               BUFFER(L:80) = BUFFER(IC:ICOL)
               CALL CFILL(BUFFER,IC,L-1,' ')
               ICOL = ICOL + NC
               WRITE(BUFFER(81:82),1001) ICOL
               REWRITE(SK1) BUFFER
               PRINT *, BUFFER(1:ICOL)
            END DO
            GO TO 100
         END IF
      END IF
C
C     DELETE LINES OR COLUMNS
C
      IF(CHAR.EQ.'D') THEN
         CHAR = INPUT(2:2)
         IF(CHAR.EQ.'L') THEN
            CALL RANGE(INPUT(3:LEN))
            EKEY = PKEY
            DELETE(SK1)
            DO WHILE (CKEY.LT.TKEY)
               READ(SK1) BUFFER
               DELETE(SK1)
            END DO
            IF(CKEY.EQ.HKEY) THEN
               READ(SK1,KEY=EKEY,ERR=75) BUFFER
               HKEY = CKEY
            ELSE
               READ(SK1) BUFFER
               PKEY = EKEY
               IF(PKEY.LT.LKEY) LKEY = CKEY
               REWRITE(SK1) BUFFER
            END IF
            READ(BUFFER(81:82),1001) ICOL
            GO TO 100
         END IF
         IF(CHAR.EQ.'C') THEN
            PRINT 1004,' Enter column(s) to be deleted: '
            CALL GETSTR(INPUT,LEN)
            CALL NUMPARSE(INPUT(1:LEN),IA,IB)
            IF(IA.EQ.0) GO TO 100
            IF(IB.EQ.0) IB = IA
            IF(IB.GT.ICOL) IB = ICOL
            LENGTH = IB - IA + 1
            PRINT 1004,' Enter range: '
            CALL GETSTR(INPUT,LEN)
            CALL RANGE(INPUT(1:LEN))
            BUFFER(IA:80) = BUFFER(IB+1:ICOL)
            ICOL = ICOL - LENGTH
            CALL CFILL(BUFFER,ICOL+1,80,' ')
            WRITE(BUFFER(81:82),1001) ICOL
            REWRITE(SK1) BUFFER
            PRINT 1004, BUFFER(1:ICOL)
            DO WHILE (CKEY.LT.TKEY)
               READ(SK1) BUFFER
               READ(BUFFER(81:82),1001) ICOL
               BUFFER(IA:80) = BUFFER(IB+1:ICOL)
               ICOL = ICOL - LENGTH
               CALL CFILL(BUFFER,ICOL+1,80,' ')
               WRITE(BUFFER(81:82),1001) ICOL
               REWRITE(SK1) BUFFER
               PRINT 1004, BUFFER(1:ICOL)
            END DO
            GO TO 100
         END IF
      END IF
C
C     FIND A CHARACTER STRING
C
      IF(CHAR.EQ.'F') THEN
         IF(INPUT(2:LEN).NE.' ') THEN
            IFS = LEN - 1
            FSTRING(1:IFS) = INPUT(2:LEN)
         END IF
         DO WHILE (CKEY.NE.HKEY)
            READ(SK1) BUFFER
            READ(BUFFER(81:82),1001) ICOL
            I = INDEX(BUFFER(1:ICOL),FSTRING(1:IFS))
            IF(I.NE.0) THEN
               PRINT 1004, BUFFER(1:ICOL)
               GO TO 100
            END IF
         END DO
         PRINT *,'  String not found  '
         GO TO 100
      END IF
C
C     SUBSTITUTE COLUMNS
C
      IF(CHAR.EQ.'S') THEN
         PRINT 1004,' Enter range of columns to be substituted: '
         CALL GETSTR(INPUT,LEN)
         CALL NUMPARSE(INPUT(1:LEN),IA,IB)
         IF(IA.EQ.0) GO TO 100
         IF(IB.EQ.0) IB = IA
         LENGTH = IB - IA + 1
         LEN = 100
         DO WHILE (LEN.GT.LENGTH)
            PRINT 1004,' Enter substitute string: '
            CALL GETSTR(INPUT,LEN)
            IF(LEN.GT.LENGTH) PRINT *,'String too long'
            STRING(1:LENGTH) = INPUT(1:LEN)
         END DO
         PRINT 1004,'Enter range of lines to be changed: '
         CALL GETSTR(INPUT,LEN)
         CALL RANGE(INPUT(1:LEN))
         BUFFER(IA:IB) = STRING(1:LENGTH)
         ICOL = MAX0(ICOL,IB)
         WRITE(BUFFER(81:82),1001) ICOL
         REWRITE(SK1) BUFFER
         PRINT 1004, BUFFER(1:ICOL)
         DO WHILE (CKEY.LT.TKEY)
            READ(SK1) BUFFER
            READ(BUFFER(81:82),1001) ICOL
            BUFFER(IA:IB) = STRING(1:LENGTH)
            ICOL = MAX0(ICOL,IB)
            WRITE(BUFFER(81:82),1001) ICOL
            REWRITE(SK1) BUFFER
            PRINT 1004, BUFFER(1:ICOL)
         END DO
         GO TO 100
      END IF
C
C     HELP SECTION
C
      IF(CHAR.EQ.'H') THEN
         I = 2
         IF(INPUT(1:2).EQ.'HE') I = 3
         IF(INPUT(1:3).EQ.'HEL') I = 4
         IF(INPUT(1:4).EQ.'HELP') I = 5
         IF(INPUT(I:I).EQ.' ') I = I + 1
         INPUT = HELP//INPUT(I:LEN)
         CALL GETHELP(INPUT)
         GO TO 100
      END IF
C
C     SAVE WORLD SECTION
C
      IF(CHAR.EQ.'W') THEN
         WORLD = .TRUE.
         INPUT(1:1) = 'Y'
         IF(IWORLD.EQ.0) INPUT(1:1) = 'N'
         IWORLD = 1
         GO TO 950
      END IF
C
C     RENUMBER THE FILE
C
      IF(CHAR.EQ.'N') THEN
         NUMBER = .TRUE.
         INPUT(1:1) = 'N'
         IF(NEW) INPUT(1:1) = 'Y'
         GO TO 950
      END IF
C
C     ACCEPTABLE CONTROL CHARACTERS IN THE MAINLINE ALL
C     DEAL WITH PROGRAM CARD. SEE SUBROUTINE 'EMULATOR'
C     FOR A COMPLETE DESCRIPTION OF CONTROL KEYS.
C
      IF(CHAR.EQ.CTRLA.OR.CHAR.EQ.CTRLB.OR.
     1   CHAR.EQ.CTRLP.OR.CHAR.EQ.CTRLV) THEN
         CALL CONTROL(CHAR)
         GO TO 100
      END IF
C
C     IF WE GOT HERE, THE COMMAND KEY WAS BAD. INFORM USER
C     AND GO BACK TO THE TOP.
C
      PRINT *,' ???? '
      GO TO 100
C
C*********************************************************************
C
C     CONTROL Z GETS US HERE. DELETE THE ORIGINAL INPUT FILE.
C     REOPEN IT NEW, THEN LOAD THE WORK FILE INTO IT.
C
  900 PRINT 1004,'   Replace original file? '
      CALL GETSTR(INPUT,LEN)
  950 IF(INPUT(1:1).EQ.'Y'.OR.NEW) THEN
         CLOSE(UNIT=1,DISPOSE='DELETE')
       ELSE
         CLOSE(UNIT=1)
         IFLEN = JFLEN
      END IF
      OPEN (UNIT=1,NAME=FILENAME(1:IFLEN),TYPE='NEW',
     1      CARRIAGECONTROL='LIST')
      READ(SK1,KEY=LKEY) BUFFER
      READ(BUFFER(81:82),1001) ICOL
      WRITE(1,1008) BUFFER(1:ICOL)
      DO WHILE (CKEY.NE.HKEY)
         READ(SK1) BUFFER
         READ(BUFFER(81:82),1001) ICOL
         WRITE(1,1008) BUFFER(1:ICOL)
      END DO
C
      IF(WORLD) GO TO 100
C
C     IF RENUMBERING, GO BACK TO BEGINNING AND REBUILD SK1.
C
      IF(NUMBER) THEN
         NEW = .FALSE.
         REWIND 1
         CLOSE(UNIT=SK1,DISPOSE='DELETE')
         IRCNT = 0
         CKEY = '000000'
         GO TO 20
      END IF
C
C     ALL DONE. CLOSE THE FILES, DELETING THE WORK FILE.
C
      CLOSE(UNIT=1,DISPOSE='KEEP')
      CLOSE(UNIT=SK1,DISPOSE='DELETE')
      CALL EXIT
C
C********************************************************************
C
C     FORMAT STATEMENTS
C
 1000 FORMAT(Q,A)
 1001 FORMAT(I2.2,I4.4,I2.2)
 1002 FORMAT(1X,'KEY ',A,'>',$)
 1003 FORMAT(I6.6)
 1004 FORMAT(1X,A,$)
 1005 FORMAT(A80)
 1006 FORMAT(BN,I2)
 1007 FORMAT('+',A,$)
 1008 FORMAT(A)
C
C*******************************************************************
      END