SUBROUTINE CONTROL(PCHAR) C C THIS SUBROUTINE HANDLES THE PROGRAM CARDS FOR KEYPUNCH. C C COMMON 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 CHARACTER*1 PCHAR,CTRLA,CTRLB,CTRLP,CTRLV,CHAR,CR,BS CHARACTER*1 DUP,WHERE,BEEP,CTRLN LOGICAL*1 STORE DATA CTRLA,CTRLB,CTRLP,CTRLV,CTRLN/Z1,Z2,Z10,Z16,ZE/ DATA DUP,WHERE,BEEP/Z04,Z17,Z07/ DATA CR,BS/ZD,Z8/ C C INITIALIZE WHATEVER C STORE = .TRUE. C C CTRL-V SHOW CURRENT PROGRAM CARD C IF(PCHAR.EQ.CTRLV) THEN PRINT 1000,PROG,MASK RETURN END IF C C CTRL-P TURN OFF PROGRAM CARD. MAKE ALL ALPHA. C IF(PCHAR.EQ.CTRLP) THEN 100 MASK(1:1) = 'A' CALL CFILL(MASK,2,80,'+') PROG = 'none' FIELD = 'A' PRINT 1000,PROG,MASK RETURN END IF C C ON THE INITIAL PASS, GO RIGHT TO PROGRAM A C IF(PCHAR.EQ.CTRLN) THEN PROG = 'A ' MASK = ' ' PRINT *,' Enter program A. defaults to all alpha. ' END IF C C CTRL-A CHANGE TO PROGRAM A. RE-DO IF REQUESTED. C IF(PCHAR.EQ.CTRLA) THEN PROG = 'A' MASK = MASKA PRINT 1000,PROG,MASK PRINT 1001 CALL GETSTR(INPUT,LEN) IF(INPUT(1:1).NE.'Y') GO TO 900 END IF C C CTRL-B CHANGE TO PROGRAM B. RE-DO IF REQUESTED. C IF(PCHAR.EQ.CTRLB) THEN PROG = 'B' MASK = MASKB PRINT 1000,PROG,MASK PRINT 1001 CALL GETSTR(INPUT,LEN) IF(INPUT(1:1).NE.'Y') GO TO 900 END IF C C IF WE GET THIS FAR, CHANGE THE PROGRAM CARD. CODE BORROWED C FROM ORIGINAL KEYPUNCH PROGRAM. C 700 JCOL=1 720 STATUS = IGETCHAR(CHAR) C C LIST ALL PROGRAMS C IF(CHAR.EQ.'L') THEN ISTAT = IGETCHAR(CHAR) OPEN(UNIT=3,TYPE='OLD',ERR=740) DO WHILE (.TRUE.) READ(3,1003,END=500) N,(MASK(J:J),J=1,N) PRINT *,MASK(1:N) END DO 500 CLOSE(UNIT=3) GO TO 700 END IF C C IF (CHAR.EQ.'#') THEN STORE = .FALSE. CALL CFILL (MASK,1,80,' ') CALL GETSTR(INPUT,LEN) READ(INPUT(1:LEN),1004,ERR=600) IRECNO OPEN(UNIT=3,TYPE='OLD',READONLY,ERR=740) I=0 725 I=I+1 IF(I.EQ.IRECNO) THEN READ(3,*,END=742) READ(3,1003,END=742)N,(MASK(J:J),J=1,MIN0(N,80)) PRINT *,MASK IF ( MASK(1:1).EQ.'+') GO TO 744 K=MIN0(N,80) L = INDEX(MASK(1:K),' ') - 1 IF(L.GT.0) K = L DO 730 J=1,K IF (MASK(J:J).NE.'A' .AND. MASK(J:J).NE.'S' + .AND. MASK(J:J).NE.'D' .AND. MASK(J:J).NE.'N' + .AND. MASK(J:J).NE.'+') GO TO 744 730 CONTINUE ELSE READ (3,*,END=742) READ (3,*,END=742) GO TO 725 END IF CLOSE(UNIT=3) IF(PROG.EQ.'A ') MASKA = MASK IF(PROG.EQ.'B ') MASKB = MASK GO TO 900 C ERRORS FROM PROGRAM CARD FILE 740 PRINT *,' No programs on file' GO TO 100 742 PRINT *,' Program #', IRECNO,' not on file' CLOSE(UNIT=3) GO TO 100 744 PRINT *,' Program has an erroneous format' CLOSE(UNIT=3) GO TO 100 END IF C C GET PROGRAM CARD BY TITLE C IF(CHAR.EQ.'$') THEN STORE = .FALSE. CALL CFILL(MASK,1,80,' ') CALL GETSTR(INPUT,LEN) 600 OPEN(UNIT=3,TYPE='OLD',ERR=744) LB = 1 IF(INPUT(1:1).EQ.' ') LB = 2 DO WHILE (.TRUE.) READ(3,1003,END=742)N,(MASK(J:J),J=1,MIN0(N,80)) I = INDEX(MASK,INPUT(LB:LEN)) IF(I.EQ.0) THEN READ(3,*,END=742) ELSE READ(3,1003,END=742)N,(MASK(J:J),J=1,MIN0(N,80)) PRINT *, MASK IF(MASK(1:1).EQ.'+') GO TO 744 K = MIN0(N,80) L = INDEX(MASK(1:K),' ') - 1 IF(L.GT.0) K = L DO 745 I=1,K CHAR = MASK(I:I) IF(CHAR.EQ.'A'.OR.CHAR.EQ.'D'.OR.CHAR.EQ.'N'.OR. 1 CHAR.EQ.'S'.OR.CHAR.EQ.'+') GO TO 745 GO TO 744 745 CONTINUE CLOSE(UNIT=3) IF(PROG.EQ.'A ') MASKA = MASK IF(PROG.EQ.'B ') MASKB = MASK GO TO 900 END IF END DO END IF C C C IF (CHAR.EQ.BS) THEN JCOL = MAX0(JCOL-1,1) PRINT 1005, ' ',BS GO TO 720 END IF IF (CHAR.EQ.DUP) THEN IF (PROG.EQ.'A') CHAR = MASKA(JCOL:JCOL) IF (PROG.EQ.'B') CHAR = MASKB(JCOL:JCOL) PRINT 1005, CHAR GO TO 750 END IF IF(CHAR.EQ.WHERE) THEN PRINT 1006,JCOL IF(JCOL.GT.1)PRINT 1007,MASK(1:JCOL-1) GO TO 720 END IF IF (CHAR.EQ.CR) THEN IF(JCOL.GT.1.AND.JCOL.LE.80)CALL CFILL(MASK,JCOL,80,' ') IF(JCOL.EQ.1) THEN STORE = .FALSE. MASK(1:1) = 'A' CALL CFILL(MASK,2,80,'+') PRINT *,MASK END IF IF(PROG.EQ.'A ') MASKA = MASK IF(PROG.EQ.'B ') MASKB = MASK GO TO 900 END IF IF (CHAR.EQ.'A' .OR. CHAR.EQ.'D' .OR. CHAR.EQ.'S' + .OR. CHAR.EQ.'N') GO TO 750 IF (JCOL.EQ.1) GO TO 790 !ERROR IF (CHAR.NE.'+') GO TO 790 !ERROR 750 MASK(JCOL:JCOL) = CHAR JCOL = JCOL + 1 IF (JCOL.GT.80) THEN IF(PROG.EQ.'A ') MASKA = MASK IF(PROG.EQ.'B ') MASKB = MASK GO TO 900 END IF GO TO 720 790 PRINT 1005, BS,' ',BS,BEEP GO TO 720 C C SAVE THE PROGRAM CARD IF THE USER SO DESIRES. ALSO, C SET FIELD POINTER C 900 IF(STORE) THEN PRINT 1005,' Do you want to save this program card?' CALL GETSTR(INPUT,LEN) IF(INPUT(1:1).EQ.'Y') THEN OPEN(UNIT=3,TYPE='UNKNOWN',ACCESS='APPEND', 1 CARRIAGECONTROL='LIST') PRINT 1007,' Enter card title: ' CALL GETSTR(INPUT,LEN) WRITE(3,1008) INPUT(1:LEN) WRITE(3,1008) MASK CLOSE(UNIT=3) END IF END IF C DO 950 I=ICOL,1,-1 IF(MASK(I:I).EQ.'+') GO TO 950 FIELD = MASK(I:I) RETURN 950 CONTINUE RETURN C C FORMAT STATEMENTS 1000 FORMAT(' Using program ',A4,':'/1X,A80) 1001 FORMAT(' Do you wish to re-enter it? ',$) 1002 FORMAT(BN,I) 1003 FORMAT(Q,80A1) 1004 FORMAT(BN,I) 1005 FORMAT('+',A,$) 1006 FORMAT('+',78X,I3) 1007 FORMAT(1X,A,$) 1008 FORMAT(A) C END