C C MAIN ROUTINE FOR CMEDIT C IMPLICIT INTEGER (A-Z) CHARACTER*255 CLINE,MBLOK(7),REC*255,BLOK,BLOKA C ,CMD*20,LCLINE*255,BLANK LOGICAL*1 B1(1),LA,LLA DATA LA,LLA/'A','a'/ EQUIVALENCE (CLINE(1:1),B1) LOGICAL MFLAG(7),X,Y,PRINT,TABS,SAVE,CRT,DOT,LINEM COMMON /WORK/ MFLAG,LN,PNTR,LRECL,PRECL,PDL COMMON /FREE/ REC COMMON /FREE2/ BLOK COMMON /VRFY/ PRINT,TABS,SAVE,DOT,LINEM COMMON /SMEM/ MBLOK,CLINE COMMON /XORY/ X,Y COMMON /ZONE/ ZS,ZE,BS,BE COMMON /TERM/ CC,LINES,IDAC,TPDL,LNO1,LNO2,KNT COMMON /WHERE/ IWRT COMMON /INNY/CQL,CQ(7),INC,ICST COMMON /CONY/ICONY COMMON /ERRORS/ERRTST,OLDPTR COMMON /CALLS/ICALL,IIN LOGICAL ICALL LOGICAL ERRTST INTEGER*4 OLDPTR INTEGER*4 IWRT DIMENSION CMD(45) INTEGER*4 SYS$CLI,SUCCESS,GETLINE(7) EXTERNAL CCTRAP C C LCLINE IS LAST COMMAND LINE. INITIALIZE IT TO N FOR NEXT C C C COMMAND TABLE C DATA CMD/'AFTER','ALTER','BEFORE','BOTTOM','CHANGE','CALL', * 'DOWN','DUP','DELETE', *'END','EXTRACT','FIND','FILE','FILENAME','FNAME','GOTO','GETFILE', * 'GETLINE','HELP','INSERT','INPUT','LOCATE','LINEM','LIST','MOVE', 1'NEXT','OVERLAY','PRINT','PUTFILE','PZONE','QUIT','REPLACE','REMOVE', * 'START','SAVE','TOP','TYPE','TABCHAR','TABDEF','TABSET','VERIFY' * ,'UP','X','Y','ZONE'/ C C CALL INIALIZATION ROUTINE C GETLINE(1) = 1 SUCCESS=SYS$CLI(%REF(GETLINE)) IF(.NOT.SUCCESS) STOP 'COMMAND LINE FAILURE FOR CMEDIT' CALL EDINIT(GETLINE(3)) BLANK=' ' ERRTST=.FALSE. LCLINE='N' ICONY = 1 40 CONTINUE C C SET UP AST FOR CONTROL C FUNCTION C IF (ICONY.EQ.1) CALL TTCC(CCTRAP) ICONY = 0 50 FORMAT('$','E>') 60 X=.FALSE. Y=.FALSE. C C GET NEXT EDIT REQUEST. C 100 CONTINUE INC = 1 IF(ICONY.EQ.1) GOTO 40 IF(DOT) PRINT=.NOT.PRINT DOT=.FALSE. IF(X.OR.Y) GO TO 120 IF(IWRT.EQ.0) THEN CLINE = 'I ' GOTO 116 ENDIF WRITE(6,50) C C READ COMMAND FROM TERMINAL C CLINE = ' ' C READ(5,485) CQL,CLINE(1:CQL) CALL TTIN(CLINE,JJJ) IF(JJJ.EQ.1) THEN IF(B1(1).EQ.'0D'X) THEN C C CR C CQL = 1 CLINE(1:) = 'N ' GOTO 130 ELSEIF (B1(1).EQ.'1A'X) THEN CQL = 1 CLINE(1:) = 'P ' ELSEIF (B1(1).EQ.'1B'X) THEN CQL = 1 CLINE(1:) = 'U ' ELSE CQL = 1 CLINE(1:3) = 'P ' ENDIF ELSEIF(JJJ.EQ.0) THEN GOTO 40 ELSE CQL = JJJ- 1 CLINE(JJJ:) = ' ' ENDIF 485 FORMAT(Q,A) 115 FORMAT(1X,A) C C IF COMMAND IS NULL REPEAT PREVIOUS COMMAND. C 116 IF(CLINE(1:2).NE.' ') GO TO 130 CLINE=LCLINE GO TO 130 C C LOAD X OR Y COMMAND C 120 CALL XYCMD(&100) 130 CONTINUE C C CHECK FOR A DOT COMMAND C IF(CLINE(1:1).EQ.'.'.OR.CLINE(1:1).EQ.'-') THEN IF (CLINE(1:1).EQ.'.') THEN PRINT=.NOT.PRINT DOT=.TRUE. ELSE INC = -1 ENDIF CLINE=CLINE(2:) CQL = CQL-1 GOTO 130 ENDIF C C NOW BEGIN PROCESS OF LOCATING COMMAND C C AND CHANGING LOWERCASE COMMANDS TO UPPER C C ASSUMTION IS MADE THAT COMMANDS HAVE PRECIDENCE C AND COMMANDS WITH SIMILARNAMES MUST BE FULLY IDENTIFIED C AS TO UNIQUENESS FOR PARSING C COMMANDS SHOULD BE LESS THEN OR EQUAL TO 20 CHARACTERS ICST = 1 DO 140 I=1,20 C C CHECK FOR ALPHA C IF(CLINE(I:I).GE.'A'.AND.CLINE(I:I).LE.'Z') THEN ELSEIF (CLINE(I:I).GE.'a'.AND.CLINE(I:I).LE.'z') THEN B1(I) = B1(I)-LLA+LA ELSE GOTO 145 ENDIF 140 ICST = ICST + 1 C C A COMMAND SHOULD HAVE BEEN IDENTIFIED C C NOW FIND OUT WHICH ONE 145 IF (ICST.EQ.1) GOTO 155 DO 149 I = 1,45 ICOMM = I IF(CLINE(1:ICST-1).EQ.CMD(I) (1:ICST-1) ) GOTO 160 149 CONTINUE C C INVALID COMMAND C 155 WRITE(6,150) CLINE(1:MAX(ICST-1,1)) 150 FORMAT(1X,A,' ???') ERRTST = .TRUE. GO TO 100 C C BRANCH FOR EACH COMMAND C 160 GOTO(1800,2500,1900,200,300,350,500,2300, * 400, * 2100,3500,1700,1000,3300,3300,1300,3400, * 1300,4000,600,600,650,3700,800, * 2200,500,2700,800,3500,3800,1100,700,2400, * 2000,1200,750,800,1650,1650,1600,1500,900,2900,3000,3100),ICOMM C C BOTTOM COMMAND C 200 PNTR=KNT IREC = IGETP(LN,PNTR) CALL BREAD(1,IREC,REC(1:LRECL)) 1150 FORMAT(1X,I7,1X,A) CALL PRINTIT(PNTR,REC(:LRECL)) ERRSTS = .FALSE. GO TO 100 C C CHANGE COMMAND C 300 CALL CHANGE GO TO 100 C CALL COMMAND C 350 CALL SETCALL GOTO 100 C C DELETE COMMAND C 400 CALL DELETE GO TO 100 C C DOWN COMMAND C 500 CALL DOWN GO TO 100 C C INSERT LINES COMMAND C 600 CALL INSERT GO TO 100 C C LOCATE STRING COMMAND C 650 CALL LOCATE GO TO 100 C C REPLACE LINES COMMAND 700 IF(CLINE(ICST:).EQ.BLANK) THEN ICST = 3 CLINE(1:ICST)='DE' CALL DELETE CLINE = 'I ' ICST = 2 CALL INSERT ELSE LCLINE = CLINE JCST = ICST ICST = 3 CLINE(1:) = 'DE' CALL DELETE CLINE = LCLINE ICST = JCST CLINE(:ICST)='I' CALL INSERT END IF GO TO 100 C C GO TO TOP OF FILE COMMAND C 750 PNTR=0 ERRTST = .FALSE. REC=' ' GO TO 100 C C TYPE OR PRINT COMMAND C 800 CALL TYPE GO TO 100 C C UP COMMAND C 900 CALL UP GO TO 100 C C SAVE AND FILE COMMANDS C 1200 CONTINUE ERRTST = .FALSE. CALL FILE(&100) GO TO 100 1000 CONTINUE CALL FILE(&100) C C QUIT COMMAND DO NOT SAVE FILE. C 1100 CONTINUE CLOSE (UNIT=90,DISP='DELETE') CLOSE (UNIT=1,DISP='DELETE') CALL EXIT C C GET LINE NUMBER C 1300 CALL GETLNO GO TO 100 C C PRINT LINE NUMBER C 1400 WRITE(6,1401) PNTR 1401 FORMAT(' PRESENT LINE NUMBER IS ',I7) GO TO 100 C C VERIFY COMMAND C 1500 PRINT=.FALSE. ERRTST = .FALSE. IF(INDEX(CLINE,'ON').NE.0) PRINT=.TRUE. IF(INDEX(CLINE,'on').NE.0) PRINT=.TRUE. GO TO 100 C C TABS COMMAND C 1600 CALL TABCMD GO TO 100 C C TAB CHARACTER C 1650 CALL TABCHR GO TO 100 C C FIND COMMAND C 1700 CALL FIND GO TO 100 C C AFTER COMMAND C 1800 CALL AFTER GO TO 100 C C BEFORE COMMAND C 1900 CALL BEFORE GO TO 100 C C BLOCK START COMMAND C 2000 BS=PNTR ERRTST = .FALSE. IF(BS.LE.0) BS = 1 GO TO 100 C C BLOCK END COMMAND C 2100 BE=PNTR ERRTST = .FALSE. GO TO 100 C C MOVE A BLOCK C 2200 CALL MOVE GO TO 100 C C DUPLICATE A BLOCK C 2300 CALL DUP GO TO 100 C C REMOVE OR DELETE A BLOCK C 2400 CALL REMOVE GO TO 100 C C ALTER COMMAND C 2500 CALL ALTER GO TO 100 C C TRUNCATE COMMAND C 2600 CALL TRUNC GO TO 100 C C OVERLAY COMMAND C 2700 CONTINUE IF(CLINE(ICST:).EQ.BLANK) THEN IF(MFLAG(7)) THEN CLINE=MBLOK(7) ICST = INDEX(CLINE,' ') ELSE WRITE(6,2710) 2710 FORMAT(' OVERLAY NOT DEFINED') ERRSTS = .TRUE. GO TO 100 END IF ELSE MFLAG(7)=.TRUE. MBLOK(7)=CLINE END IF ICST = ICST + 1 CALL WORKTB ICST = ICST - 1 DO 2701 I=1,LRECL J=I+ICST IF(J.GT.255) GO TO 2701 IF(CLINE(J:J).EQ.' ') GO TO 2701 REC(I:I)=CLINE(J:J) 2701 CONTINUE ERRTST = .FALSE. IREC = IGETP(LN,PNTR) CALL BWRITE(1,IREC,REC(1:LRECL)) GO TO 100 C C MERGE COMMAND C 2800 CALL MERGE GO TO 100 C C X COMMAND C 2900 X=.TRUE. CALL XYCMD(&100) GO TO 100 C Y COMMAND 3000 Y=.TRUE. CALL XYCMD(&100) GO TO 100 C C ZONE COMMAND C 3100 CALL ZONED GO TO 100 C C TERMINAL COMMAND C 3200 CALL TERM GO TO 100 C C FNAME COMMAND ????? C 3300 CALL FNAME GO TO 100 C C GET COMMAND (MERGE) C 3400 CALL GETFIL GO TO 100 C C PUT COMMAND 3500 CALL PUTFIL GO TO 100 C C DISPLAY THE SHORT MEMORY C 3600 CALL SHTMEM GO TO 100 C C SET LINEMODE C 3700 LINEM = .TRUE. IF(INC.LT.0) LINEM=.FALSE. GOTO 100 C C SET PRINT ZONE C 3800 CALL PZONE GOTO 100 C 4000 CONTINUE IF(CLINE(ICST:).EQ.' ')CQL = ICST+5 CALL HELP(CLINE(ICST+1:CQL)) GOTO 100 END SUBROUTINE ALTER C C CMEDIT ROUTINE TO ALTER STRINGS C FORMAT A N C N IS NUMBER OF LINES TO ALTER C IMPLICIT INTEGER (A-Z) CHARACTER*255 MBLOK(7),CLINE,DELIM*1,REC,TMP CHARACTER*255 WORK LOGICAL MFLAG(7),PRINT,DOT,CHA,AFT,BEF COMMON /WORK/ MFLAG,LN,PNTR,LRECL,PRECL,PDL COMMON /CONY/ICONY COMMON /ERRORS/ERRTST,OLDPTR LOGICAL ERRTST INTEGER*4 OLDPTR COMMON /VRFY/ PRINT,TAB,SAVE,DOT,LINEM COMMON /SMEM/ MBLOK,CLINE COMMON /FREE/ REC COMMON /FREE2/ TMP COMMON /ZONE/ ZS,ZE,BS,BE COMMON /TERM/ CC,LINES,IDAC,TPDL,LNO1,LNO2,KNT COMMON /WHERE/ IWRT COMMON /INNY/CQL,CQ(7),INC,ICST INTEGER*4 IWRT LOGICAL LINETMP,PTEMP CHARACTER*1 BL C DATA BL /' '/ C LOCATE NUMBER OF LINES TO ALTER ERRTST = .FALSE. C DO 3 M = ICST,80 DL1 = M IF(CLINE(M:M).NE.' ') GOTO 4 3 CONTINUE C BLANK CARD THEREFORE NAL = 1 NAL = 1 GOTO 100 4 DL2 = INDEX(CLINE(DL1+1:),' ') IF(DL2.EQ.0) DL2=1 C C NOW DECODE THE VALUE FOR PROPER COUNT C DECODE(DL2,50,CLINE(DL1:DL1+DL2-1),ERR=80)NAL GOTO 100 80 NAL = 1 50 FORMAT(I) 100 CONTINUE C C ASSURE RECORD IN RANGE C IF(PNTR.LE.0) THEN PNTR = 1 IREC = IGETP(LN,PNTR) CALL BREAD(1,IREC,REC(1:LRECL)) ENDIF C C NOW THE NUMBER OF LINES HAS BEEN RESOLVED C SET UP LOOP FOR NUMBER OF LINES C APPROPRIATE TO DIRECTION OF TRAVEL C C ASSUME FIRST RECORD IS IN REC C DO 1000 IREC = 1,NAL 110 LINETMP = LINEM PTEMP = PRINT PRINT = .TRUE. LINEM = .TRUE. CALL PRINTIT(PNTR,REC(:LRECL)) LINEM = LINETMP PRINT = PTEMP 12000 FORMAT(1X,I7,1X,A) 12001 FORMAT('$',I6,'A>') WRITE(6,12001)PNTR C NOW THE RECORD HAS BEEN ECHOED INPUT CORRECTIONS C CALL TTIN(CLINE,JJJ) CQL = JJJ-1 CLINE(JJJ:) = ' ' IF(ICONY.EQ.1) RETURN IF(CQL.LE.0) GOTO 700 C C THERE IS INPUT NOW PROCESS TRANSACTION C C P1 = POINTER IN REC C P2 = POINTER IN CLINE C P3 & P4 WORK POINTERS P1 = 1 P2 = 1 150 CONTINUE IF(P2.GT.CQL)GOTO 110 C CHECK FOR END OF CLINE PROCESSING C C CHECK FOR NEXT NONBLANK CHARACTER C I = VERIFY(CLINE(P2:CQL),' ') IF(I.EQ.0) THEN IF(P1.NE.1) THEN GOTO 110 ELSE GOTO 700 ENDIF ENDIF C C UPDATE POINTERS TO REFLECT NEW POSITION C P1 = P1+I-1 P2 = P2 +I-1 IF (CLINE(P2:P2).EQ.'#') THEN ! INSERT A BLANK REC(P1:P1) = ' ' P1 = P1 + 1 P2 = P2 + 1 ELSE IF(CLINE(P2:P2).EQ.'@') THEN ! DELETE A CHARACTER REC(P1:LRECL) = REC(P1+1:LRECL) P2 = P2 + 1 ELSE IF(CLINE(P2:P2).EQ.'%') THEN ! DELIMITER STRING DELIM = CLINE(P2+1:P2+1) C C CHECK TO SEE IF DELIM REOCCURS IN CLINE C IF DELIM IS NOT A BLANK OR A % C IF(DELIM.NE.'%'.AND.DELIM.NE.' ') THEN II = INDEX(CLINE(P2+2:CQL),DELIM) IF (II.GT.0) THEN ! INSERT STRING WORK = REC REC = WORK(:P1-1)//CLINE(P2+2:P2+II) //WORK(P1:) P1 = P1 + II - 1 P2 = P2+II + 2 ELSE ! NOT A STRING SO INSERT A BLANK WORK = REC REC = WORK(:P1-1)//BL//WORK(P1:) P1 = P1+1 P2 = P2 +1 ENDIF ELSE ! INSERT A BLANK WORK = REC REC = WORK(:P1-1)//BL//WORK(P1:) P1 = P1+1 P2 = P2 + 1 ENDIF ELSE ! REPLACE CHARACTER REC(P1:P1) = CLINE(P2:P2) P1 = P1 + 1 P2 = P2 + 1 ENDIF C C NOW GO BACK AND LOOK AT NEXT STUFF C GOTO 150 C C END OF LOOP FOR A LINE C 700 IF(ICONY.EQ.1)RETURN C C NOW WRITE CURRENT RECORD AND GET NEXT (IF APPROPRIATE) C IRRR = IGETP(LN,PNTR) CALL BWRITE(1,IRRR,REC(1:LRECL)) NPNTR = PNTR+INC IF(NPNTR.GT.KNT.OR.NPNTR.LT.1) RETURN IF(IREC.EQ.NAL) RETURN PNTR = NPNTR IRRR = IGETP(LN,PNTR) CALL BREAD(1,IRRR,REC(1:LRECL)) 1000 CONTINUE RETURN END SUBROUTINE CHANGE C C CMEDIT ROUTINE TO CHANGE STRINGS C FORMAT C /XXX/YYY/ LL OO C / IS THE DELIMITER CAN BE ANY CHARACTER C XXX IS THE STRING TO FIND C YYY IS THE STRING THAT REPLACES XXX C LL IS THE NUMBER OF LINES TO SEARCH C OO IS THE NUMBER OF THE STRING TO CHANGE IN EACH LINE C IMPLICIT INTEGER (A-Z) CHARACTER*255 MBLOK(7),CLINE,DELIM*1,REC,TMP CHARACTER*255 WREC LOGICAL MFLAG(7),PRINT,DOT,CHA,AFT,BEF COMMON /WORK/ MFLAG,LN,PNTR,LRECL,PRECL,PDL COMMON /CONY/ICONY COMMON /ERRORS/ERRTST,OLDPTR LOGICAL ERRTST INTEGER*4 OLDPTR COMMON /VRFY/ PRINT,TAB,SAVE,DOT,LINEM COMMON /SMEM/ MBLOK,CLINE COMMON /FREE/ REC COMMON /FREE2/ TMP COMMON /ZONE/ ZS,ZE,BS,BE COMMON /TERM/ CC,LINES,IDAC,TPDL,LNO1,LNO2,KNT COMMON /WHERE/ IWRT COMMON /INNY/CQL,CQ(7),INC,ICST INTEGER*4 IWRT DATA CHA,AFT,BEF/.FALSE.,.FALSE.,.FALSE./ CHA=.TRUE. 1 CONTINUE C C LOCATE THE DELIMITERS C ERRTST = .FALSE. OLDPTR = PNTR DO 3 M=ICST,80 DL1=M IF(CLINE(M:M).NE.' ') GO TO 4 3 CONTINUE M=0 C C BLANK CARD CHECK MEMORY FOR PREVIOUS CHANGE COMMAND. C IF(CHA.AND..NOT.MFLAG(3)) GO TO 80 IF(CHA)CLINE=MBLOK(3) IF(CHA)CQL = CQ(3) IF(AFT.AND..NOT.MFLAG(1)) GO TO 80 IF(AFT) CLINE=MBLOK(1) IF(AFT) CQL=CQ(1) IF(BEF.AND..NOT.MFLAG(2)) GO TO 80 IF(BEF) CLINE=MBLOK(2) IF(BEF) CQL = CQ(2) C C NEW CLINE NOW LOCATE ICST C ICST = 1 DO 2 I= 1,20 IF(CLINE(I:I).GE.'A'.AND.CLINE(I:I).LE.'Z') GOTO 2 GOTO 1 2 ICST = ICST + 1 GO TO 1 C C SET DEFAULT PARAMETERS C 4 ALL = 1 NLN=1 OCCUR=0 NOCCUR = 1 DELIM=CLINE(DL1:DL1) DL2=INDEX(CLINE(DL1+1:),DELIM)+DL1 IF(DL2.EQ.DL1) GO TO 200 DL3=INDEX(CLINE(DL2+1:),DELIM)+DL2 IF(DL2.EQ.DL3)DL3=CQL+1 IF(CLINE(DL3+1:).EQ.' ') GO TO 20 SL=DL3+1 DO 10 J=1,2 DO 7 II=SL,135 I=II K=1 IF(CLINE(I:I).EQ.' ') GO TO 7 IF(CLINE(I:I).EQ.'*') GO TO 8 IF(CLINE(I:I).EQ.'G') GOTO 18 6 IF(CLINE(I+K:I+K).EQ.' ') GO TO 9 K=K+1 GO TO 6 7 CONTINUE GO TO 20 8 IF(J.EQ.1) NLN=100000 IF(J.EQ.2) ALL=LRECL GO TO 19 C C GLOBAL CHANGE C 18 IF(J.EQ.1)NLN=100000 ALL = LRECL GOTO 19 9 ENCODE(K,710,BUF) CLINE(I:I+K-1) DECODE(K,711,BUF,ERR=88) LDUM 710 FORMAT(A) 711 FORMAT(I) IF(J.EQ.1) NLN=LDUM IF(J.EQ.2) NOCCUR=LDUM 19 SL = I + K 10 CONTINUE 20 IF(CHA)MBLOK(3)=CLINE IF(CHA)MFLAG(3)=.TRUE. IF(CHA)CQ(3) = CQL IF(BEF) MFLAG(2)=.TRUE. IF(BEF) MBLOK(2)=CLINE IF(BEF) CQ(2) = CQL IF(AFT) MFLAG(1)=.TRUE. IF(AFT) MBLOK(1)=CLINE IF(AFT) CQ(1) = CQL C C CALCULATE FIELD SIZES C 23 SZOLD=DL2-DL1-1 CALL HEXOCT(CLINE(DL1+1:DL1+SZOLD),SZOLD) SZNEW=DL3-DL2-1 CALL HEXOCT(CLINE(DL2+1:DL2+SZNEW),SZNEW) COUNT=0 IF(KNT.LT.PNTR+NLN-1) NLN=KNT-PNTR+1 FOUND=0 DO 68 ILN=1,NLN OCCUR=0 ILOC=1 OCCUR1 = 0 IF(PNTR.LE.0) GO TO 67 C REC(LRECL+1:) = ' ' WREC = REC(ZS:ZE) ZZE = ZE-ZS+1 WREC(ZZE+1:) = ' ' C START MODIFYING THE RECORDS C DO 50 I=1,ALL C C TRY TO LOCATE OLD STRING IN RECORD C 34 FIELD=ILOC NC=ZZE-ILOC+1 IF (SZOLD.EQ.0) GOTO 24 IF(NC.LT.SZOLD) GO TO 55 FIELD=INDEX(WREC(ILOC:ZZE),CLINE(DL1+1:DL1+SZOLD))+ILOC-1 IF(FIELD.EQ.ILOC-1) GO TO 55 OCCUR1 = OCCUR1 + 1 IF (OCCUR1.GE.NOCCUR)GOTO 24 ILOC = FIELD+SZOLD GOTO 34 24 OCCUR=OCCUR+1 FOUND=FOUND+1 25 COUNT=COUNT+1 IF(CHA) THEN IF(DL2+1.LT.DL3) THEN WREC=WREC(:FIELD-1)//CLINE(DL2+1:DL2+SZNEW)//WREC(FIELD+SZOLD:) ELSE WREC=WREC(:FIELD-1)//WREC(FIELD+SZOLD:) END IF END IF IF(AFT) THEN WREC=WREC(:FIELD+SZOLD-1)//CLINE(DL2+1:DL2+SZNEW)//WREC(FIELD 1 +SZOLD:) FIELD=FIELD+SZOLD END IF IF(BEF) THEN WREC=WREC(:FIELD-1)//CLINE(DL2+1:DL2+SZNEW)//WREC(FIELD:) FIELD=FIELD+SZOLD END IF ILOC=FIELD+SZNEW 50 CONTINUE 55 IF(FOUND.EQ.0.AND.SZOLD.NE.0) GO TO 67 IF(FOUND.LT.OCCUR) GO TO 67 IF(OCCUR.GT.0) REC = REC(:ZS-1)//WREC(:ZZE)//REC(ZE+1:) IF(OCCUR.GT.0) CALL PRINTIT(PNTR,REC(:LRECL)) 1000 FORMAT(1X,I7,1X,A) IF(OCCUR.GT.0) THEN IREC = IGETP(LN,PNTR) CALL BWRITE(1,IREC,REC(1:LRECL)) OLDPTR = PNTR ENDIF 67 IF(ILN.EQ.NLN) GO TO 68 IF(PNTR+INC.GT.KNT.OR.PNTR+INC.LT.1) GOTO 68 IF(ICONY.EQ.1) GOTO 86 PNTR=PNTR+INC IREC = IGETP(LN,PNTR) CALL BREAD(1,IREC,REC(1:LRECL)) C C UPDATE THE POINTER FOR THE NEXT RECORD C 68 CONTINUE C RL AND LL ARE FUNCTIONS. REPLACE THEM WITH SOMETHING C 70 IF(COUNT.EQ.0) GO TO 72 GO TO 86 72 NWRD=(SZOLD+2)/2 WRITE(6,75) CLINE(DL1+1:DL2-1) ERRTST = .TRUE. 75 FORMAT(' CANNOT FIND ',A) GO TO 86 80 WRITE(6,85) ERRTST = .TRUE. 85 FORMAT(' NO DELIMITER!') 86 CONTINUE PNTR = OLDPTR IF(PNTR.NE.0) THEN IREC = IGETP(LN,PNTR) CALL BREAD(1,IREC,REC(1:LRECL)) ENDIF AFT=.FALSE. BEF=AFT CHA=AFT RETURN 88 WRITE(6,100) 100 FORMAT(' INVALID OPERAND') ERRTST = .TRUE. GO TO 86 C C CHANGE WITH NO SECOND DELIMITER C LOCATE STRING IN RECORD C & ENTER INPUT MODE C 200 IF(AFT) GOTO 80 IF(CHA)CQ(3) = CQL IF(CHA)MBLOK(3) = CLINE IF(BEF) MBLOK(2) = CLINE IF(BEF) CQ(2) = CQL C C TAKE NOTICE OF ZONE DEFINING AREA C ILOC = INDEX(REC(ZS:ZE),CLINE(DL1+1:CQL)) DL2 = CQL+1 IF(ILOC.EQ.0)GOTO 72 IF(ILOC.GT.1) THEN ILOC = ILOC + ZS -1 WRITE(6,12020)PNTR,REC(:ILOC-1) ELSE WRITE(6,12030)PNTR ENDIF 12030 FORMAT(1X,I7,1X,$) 12020 FORMAT(1X,I7,1X,A,$) READ(5,11000,END=250,ERR=250)JJJ,CLINE IF(JJJ.LE.0) GOTO 250 11000 FORMAT(Q,A) REC(ILOC:ZE) = CLINE(:JJJ) CALL PRINTIT(PNTR,REC(:LRECL)) IREC = IGETP(LN,PNTR) CALL BWRITE(1,IREC,REC(1:LRECL)) GOTO 86 250 WRITE(6,*)' NO CHANGES' GOTO 86 ENTRY BEFORE BEF=.TRUE. GO TO 1 ENTRY AFTER AFT=.TRUE. GO TO 1 END SUBROUTINE DELETE C C DELETE ROUTINE WILL DELETE LINES IN DATA SET C DE (DELETES PRESENT LINE) C DE * (DELETES FROM/INCLUDE PRESENT LINE TO END) C DE N (N IS INTEGER.DELETES N LINES START AT PRESENT) C DE N M (N,M ARE INTEGERS) DELETE LINES N TO M C IMPLICIT INTEGER (A-Z) CHARACTER*255 MBLOK(7),CLINE,DELIM*1,REC,TMP LOGICAL MFLAG(7),PRINT,DOT,LINEM COMMON /WORK/ MFLAG,LN,PNTR,LRECL,PRECL,PDL COMMON /VRFY/ PRINT,TAB,SAVE,DOT,LINEM COMMON /ERRORS/ERRTST,OLPTR LOGICAL ERRTST INTEGER*4 OLPTR COMMON /SMEM/ MBLOK,CLINE COMMON /FREE/ REC COMMON /FREE2/ TMP COMMON /ZONE/ ZS,ZE,BS,BE COMMON /TERM/ CC,LINES,IDAC,TPDL,LNO1,LNO2,KNT COMMON /WHERE/ IWRT INTEGER*4 IWRT IND=INDEX(CLINE,' ') DO 1 I=IND,80 II=I IF(CLINE(I:I).NE.' ') GO TO 3 1 CONTINUE N=1 2 CONTINUE IF(PNTR.EQ.0)N=N-1 ERRTST = .FALSE. IF(N.EQ.0) RETURN IF(PNTR.EQ.0)PNTR=1 K=PNTR KN=KNT-N IF((BS.GE.PNTR.AND.BS.LE.KN).OR.(BE.GE.PNTR.AND.BE.LE.KN))THEN BS = 0 BE = 0 ELSE IF(BS.GT.KN)BS = BS-N IF(BE.GT.KN)BE = BE-N ENDIF DO 4 KK=PNTR,KN KR=KK+N KW=KK CALL ISETP(LN,KW,IGETP(LN,KR)) 4 CONTINUE PNTR=PNTR-1 5 KK=PNTR IF(KK.GT.0) THEN IREC = IGETP(LN,KK) CALL BREAD(1,IREC,REC(1:LRECL)) ENDIF KNT = MAX(0,KNT-N) ERRTST = .FALSE. RETURN 3 CONTINUE IF(CLINE(II:II).EQ.'*'.OR.CLINE(II:II).EQ.'G') THEN N = 1000000 GOTO 8 ENDIF IND=INDEX(CLINE(II:),' ')-1 DECODE(IND,100,CLINE(II:II+IND-1),ERR=10) N 100 FORMAT(I) 8 IF(PNTR+N.GT.KNT) THEN IF(PNTR.LE.BS.OR.PNTR.LE.BE) THEN BS = 0 BE = 0 ENDIF KNT=PNTR-1 PNTR=KNT N=0 GO TO 5 ELSE GO TO 2 END IF 10 CONTINUE C C DELETE LINES ACCORDING TO STRINGS. C C FIRST FIND THE STRING/STRINGS IN THE COMMAND CARD. C C THIS OUTINE TO BE FINISHED LATER GO TO 5 ENTRY REMOVE IF(BS.GT.BE) GO TO 50 IF(BS.LT.1) GO TO 50 IF(BE.GT.KNT) GO TO 50 IF(BS.GT.KNT) GO TO 50 IF(BE.LT.1) GO TO 50 PNTR=BS N=BE-BS+1 BS = 0 BE = 0 GO TO 2 50 CONTINUE WRITE (6,51) BS,BE ERRTST = .TRUE. 51 FORMAT(' BLOCK NOT DEFINED ',2I8) RETURN END SUBROUTINE DOWN C C DOWN ROUTINE WILL MOVE THE LINE POINTER DOWN C D OR DO (MOVE POINTER DOWN 1 LINE) C D OR DO * (MOVES POINTER TO BOTTOM LINE) C D OR DO N (MOVES POINTER DOWN N LINES. DEFAULT N=1) C IMPLICIT INTEGER (A-Z) CHARACTER*255 MBLOK(7),CLINE,DELIM*1,REC,TMP LOGICAL MFLAG(7),PRINT,DOT,LOGIC,LTYPE LOGICAL PTEMP COMMON /WORK/ MFLAG,LN,PNTR,LRECL,PRECL,PDL COMMON /CONY/ICONY COMMON /ERRORS/ERRTST,OLDPTR LOGICAL ERRTST INTEGER*4 OLDPTR COMMON /VRFY/ PRINT,TAB,SAVE,DOT,LINEM COMMON /SMEM/ MBLOK,CLINE COMMON /FREE/ REC COMMON /FREE2/ TMP COMMON /ZONE/ ZS,ZE,BS,BE COMMON /TERM/ CC,LINES,IDAC,TPDL,LNO1,LNO2,KNT COMMON /WHERE/ IWRT INTEGER*4 IWRT COMMON /INNY/CQL,CQ(7),INC,ICST DATA LOGIC/.FALSE./,LTYPE/.FALSE./ 50 CONTINUE ERRTST = .FALSE. IF(INC.LT.0) LOGIC = .NOT.LOGIC IF(LTYPE) PNTR = MAX(0,PNTR-1) SAV=PNTR+1 IND=INDEX(CLINE,' ') DO 1 I=IND,80 II=I IF(CLINE(I:I).NE.' ') GO TO 3 1 CONTINUE N=1 IF(.NOT.LOGIC.AND.PNTR.EQ.KNT) N=0 2 CONTINUE IF(LOGIC) N=-N PNTR=PNTR+N IF(PNTR.GT.KNT) PNTR=KNT IF(PNTR.LT.0) PNTR=0 IF(PNTR.EQ.0) GO TO 5 IF(LTYPE) GO TO 60 KR=PNTR IF(ICONY.EQ.1) GOTO 5 IREC = IGETP(LN,KR) CALL BREAD(1,IREC,REC(1:LRECL)) CALL PRINTIT(PNTR,REC(:LRECL)) 4 CONTINUE 5 KK=PNTR IF(PNTR.EQ.0) WRITE(6,151) 151 FORMAT(' TOP OF FILE') LOGIC=.FALSE. RETURN 3 IF(CLINE(II:II).EQ.'*') GO TO 7 IND=INDEX(CLINE(II:),' ')-1 DECODE(IND,100,CLINE(II:II+IND-1),ERR=10) N GO TO 2 60 CONTINUE IF(SAV.GT.KNT) SAV=KNT DO 61 I=SAV,PNTR,INC IF(ICONY.EQ.1) GOTO 61 IREC = IGETP(LN,I) CALL BREAD(1,IREC,REC(1:LRECL)) PTEMP = PRINT PRINT = .TRUE. CALL PRINTIT(I,REC(:LRECL)) PRINT = PTEMP 61 CONTINUE LTYPE=.FALSE. RETURN 102 FORMAT(1X,I7,1X,A) 7 N=KNT-PNTR GO TO 2 10 CONTINUE WRITE(6,101) 100 FORMAT(I) ERRTST = .TRUE. 101 FORMAT(' INVALID FORMAT ON DOWN COMMAND.REENTER') GO TO 5 ENTRY UP LOGIC=.TRUE. GO TO 50 ENTRY TYPE LTYPE=.TRUE. GO TO 50 END SUBROUTINE EDINIT(CLISTR) C C EDITOR INITIALIZATION ROUTINE C IMPLICIT INTEGER (A-Z) CHARACTER*255 CLINE,MBLOK(7),REC,BLOK,NULL*1 LOGICAL MFLAG(7),X,Y,PRINT,TABS,DOT,LINEM COMMON /WORK/ MFLAG,LN,PNTR,LRECL,PRECL,PDL COMMON /FREE/ REC COMMON /FREE2/ BLOK COMMON /VRFY/ PRINT,TABS,SAVE,DOT,LINEM COMMON /SMEM/ MBLOK,CLINE COMMON /XORY/ X,Y COMMON /TERM/ CC,LINES,IDAC,TPDL,LNO(2),KNT COMMON /ZONE/ ZSTART,ZEND,BS,BE COMMON /WHERE/ IWRT COMMON /PSIZE/ ICSTART,ICEND INTEGER*4 IWRT COMMON /CALLS/ICALL,IIN LOGICAL ICALL COMMON /TABCM1/TCHAR COMMON /TABCM2/NTAB,ITAB(100) CHARACTER TCHAR*1 CHARACTER CLISTR*(*) LOGICAL NEW,ISEMI CHARACTER INFILE*40,OUTFILE*40 DATA NULL/0/ C C INITIALIZE VARIABLES C LN=1 IIN = 5 ICALL = .FALSE. BS=0 BE=0 DOT=.FALSE. LNO1=1 LNO2=1 PRINT=.TRUE. LINEM = .TRUE. TABS=.FALSE. NTAB = 7 TCHAR = '>' ITAB(1) = 7 ITAB(2) = 21 ITAB(3) = 31 ITAB(4) = 41 ITAB(5) = 51 ITAB(6) = 61 ITAB(7) = 73 LINES=1 ZSTART=1 ZEND=255 LRECL=255 DO 1 I=1,7 1 MFLAG(I)=.FALSE. KNT=0 IWRT = 0 NEW = .FALSE. OPEN(UNIT=6,NAME='SYS$OUTPUT',RECORDSIZE=255) OPEN(UNIT=5,NAME='SYS$INPUT',RECORDSIZE=255) C C C C COMMAND LINE TRANSLATION C C CHARACTER STRING SHOULD BE FILE NAME OF INPUT FILE C IF BLANK PROMPT FOR INPUT FILE NAME INFILE = CLISTR IF (INFILE.NE.' ') GOTO 1011 10 TYPE 12100 12100 FORMAT(1X,'ENTER FILE NAME :',$) READ(5,11100)INFILE 11100 FORMAT(A) 1011 OPEN(UNIT=90,NAME=INFILE,TYPE='OLD',READONLY,ERR=5) JSEMI = INDEX(INFILE,';') IF (JSEMI.LT.40) ISEMI= .TRUE. GOTO 11 5 CALL ERRSNS(IERR) IF (IERR.EQ.29) THEN IF(ISEMI) THEN WRITE(6,*)'FILE:',INFILE,' DOES NOT EXIST' GOTO 10 ELSE WRITE(6,140) NEW = .TRUE. GOTO 11 ENDIF ELSE IF(IERR.EQ.43) THEN WRITE(6,*)'FILENAME: ',INFILE,' WAS BAD' ELSE IF(IERR.EQ.34) THEN WRITE(6,*) ' FILE ALREADY OPEN' ELSE WRITE (6,*)' OPEN FAILUE ON ',INFILE,' I/O ERROR CODE',IERR ENDIF GOTO 10 11 WRITE(6,111) 111 FORMAT(' INPUT MAX RECORD LENGTH :',$) READ(5,*,ERR=11) LRECL IF(LRECL.EQ.0) LRECL=80 IF(LRECL.GT.254) GO TO 11 ICSTART = 1 ICEND = LRECL LR=(LRECL+1)/2 LNO1=1 C DEFINE FILE 1 (50000,LR,U,LNO1) OPEN(UNIT=1,RECORDTYPE='FIXED',TYPE='NEW',NAME='CMEDIT.WRK', 1 ASSOCIATEVARIABLE=LNO1,RECORDSIZE=(LRECL+3)/4, 2 FORM='UNFORMATTED',ACCESS='DIRECT') C IF(NEW) RETURN C READ THE INPUT FILE ; MOVE TO SCRATCH NUMBER 1. C 2 READ(90,100,END=3) CLINE KNT=KNT+1 100 FORMAT(A) CALL BWRITE(1,KNT,CLINE(1:LRECL)) CALL ISETP(LN,KNT,KNT) GO TO 2 3 CLOSE (UNIT=90) IWRT = KNT 140 FORMAT(' NEW FILE') RETURN ENTRY FNAME WRITE(6,12300)INFILE 12300 FORMAT(1X,'THE INPUT FILE NAME IS: ',A) RETURN ENTRY FILE(*) IND=INDEX(CLINE,' ') DO 49 I=IND,80 II=I IF(CLINE(I:I).NE.' ') GO TO 52 49 CONTINUE IF(ISEMI) INFILE = INFILE(1:JSEMI-1) OPEN (UNIT=90,TYPE='NEW',RECORDSIZE=LRECL, 1 CARRIAGECONTROL='LIST',NAME=INFILE,ERR=5000) DO 51 I=1,KNT KK=I IREC = IGETP(LN,KK) CALL BREAD(1,IREC,REC(1:LRECL)) DO 500 II = LRECL,1,-1 LNREC = II IF(REC(II:II).NE.' ')GOTO 510 500 CONTINUE 510 CONTINUE WRITE(90,100) REC(:LNREC) 51 CONTINUE CLOSE (UNIT=90,DISP='KEEP') WRITE(6,121) INFILE RETURN 5000 WRITE(6,*)' OPEN FAILURE ON FILE:',INFILE RETURN 1 52 CONTINUE IND=INDEX(CLINE(II:),' ') OPEN (UNIT=91,TYPE='NEW',RECORDSIZE=LRECL, C CARRIAGECONTROL='LIST',ERR=5100, C NAME=CLINE(II:II+IND-2)) DO 53 I=1,KNT KK=I IREC = IGETP(LN,KK) CALL BREAD(1,IREC,REC(1:LRECL)) DO 600 JJ =LRECL,1,-1 LNREC = JJ IF (REC(JJ:JJ).NE.' ')GOTO 610 600 CONTINUE 610 WRITE(91,100) REC(:LNREC) 53 CONTINUE CLOSE (UNIT=91,DISP='KEEP') WRITE(6,121) CLINE(II:II+IND-2) 121 FORMAT(' WRITTEN TO FILE ',A) RETURN 5100 WRITE(6,*)' OPEN FAILURE ON FILE:',CLINE(II:II+IND-2) RETURN 1 END SUBROUTINE FIND C C FIND A CHARACTER STRING COLUMN DEPENDENT. C C F OR FIND FOLLOWED BY A BLANK FOLLOWED BY THE STRING. C ONLY NON-BLANK CHARACTERS ARE MATCHED. C IMPLICIT INTEGER (A-Z) CHARACTER*255 CLINE,MBLOK(7),REC*255,BLOK*255 LOGICAL MFLAG(7),X,Y,PRINT,TABS,DOT,LINEM COMMON /WORK/ MFLAG,LN,PNTR,LRECL,PRECL,PDL COMMON /CONY/ICONY COMMON /ERRORS/ERRTST,OLDPTR LOGICAL ERRTST INTEGER*4 OLDPTR COMMON /FREE/ REC COMMON /FREE2/ BLOK COMMON /VRFY/ PRINT,TABS,SAVE,DOT,LINEM COMMON /SMEM/ MBLOK,CLINE COMMON /XORY/ X,Y COMMON /TERM/ CC,LINES,IDAC,TPDL,LNO1,LNO2,KNT COMMON /WHERE/ IWRT COMMON /INNY/CQL,CQ(7),INC,ICST INTEGER*4 IWRT NM=0 ERRTST = .TRUE. OLDPTR = PNTR L=INDEX(CLINE,' ') S=L+1 ICST = S CALL WORKTB DO 1 I=S,135 IF(CLINE(I:I).NE.' ') GO TO 2 1 CONTINUE IF(.NOT.MFLAG(4)) GO TO 91 CLINE=MBLOK(4) CQL = CQ(4) L=INDEX(CLINE,' ') S=L+1 2 CONTINUE C C SAVE FIND COMMAND LINE IN MEMORY FOR NEXT TIME. C MBLOK(4)=CLINE CQ(4) = CQL MFLAG(4)=.TRUE. 5 CONTINUE KK=PNTR+INC IF(PNTR+INC.GT.KNT.OR.PNTR+INC.LT.1) GOTO 92 IF(ICONY.EQ.1) RETURN IREC = IGETP(LN,KK) CALL BREAD(1,IREC,REC(1:LRECL)) CCC NOTICE ***************** END=92 HERE ************ PNTR=PNTR+INC C C MATCH LINE AGAINST THIS RECORD. C IF(CLINE(S:CQL).NE.REC(:CQL-S+1)) GOTO 5 C MUST BE A MATCH TO GET HERE. OLDPTR = PNTR CALL PRINTIT(PNTR,REC(:LRECL)) 1000 FORMAT(1X,I7,1X,A) 80 PNTR = OLDPTR IF(PNTR.NE.0) THEN IREC = IGETP(LN,PNTR) CALL BREAD(1,IREC,REC(1:LRECL)) ENDIF RETURN 91 WRITE(6,20) ERRTST = .TRUE. 20 FORMAT(' NO STRING TO FIND') GO TO 80 92 WRITE(6,40) ERRTST = .TRUE. 40 FORMAT(' NOT FOUND EOT...') GO TO 80 END SUBROUTINE GETFIL C C EDITOR INITIALIZATION ROUTINE C IMPLICIT INTEGER (A-Z) CHARACTER*255 CLINE,MBLOK(7),REC,BLOK,NULL*1 LOGICAL MFLAG(7),X,Y,PRINT,TABS,DOT,LINEM COMMON /WORK/ MFLAG,LN,PNTR,LRECL,PRECL,PDL COMMON /ERRORS/ERRTST,OLPTR LOGICAL ERRTST INTEGER*4 OLPTR COMMON /FREE/ BLOK COMMON /FREE2/ REC COMMON /VRFY/ PRINT,TABS,SAVE,DOT,LINEM COMMON /SMEM/ MBLOK,CLINE COMMON /XORY/ X,Y COMMON /TERM/ CC,LINES,IDAC,TPDL,LNO(2),KNT COMMON /ZONE/ ZSTART,ZEND,BS,BE COMMON /WHERE/ IWRT INTEGER*4 IWRT DATA NULL/0/ C C INITIALIZE VARIABLES C N1=0 ERRTST = .FALSE. N2=0 N3=0 IE=80 IND=INDEX(CLINE,' ') DO 1 I=IND,80 II=I IF(CLINE(I:I).NE.' ') GO TO 3 1 CONTINUE 2 CONTINUE WRITE(6,2001) CLINE(II:IE) 2001 FORMAT(' BAD INPUT FILE NAME ON GETFILE'/1X,A) RETURN 3 IE=INDEX(CLINE(II:),' ')+II-2 JND=IE+1 DO 11 I=JND,80 IJ=I IF(CLINE(I:I).NE.' ') GO TO 4 11 CONTINUE GO TO 9 4 FN1=INDEX(CLINE(IJ:),' ')+IJ-2 XB=FN1-IJ+1 DECODE(XB,100,CLINE(IJ:),ERR=91) N1 KND=FN1+1 DO 12 I=KND,80 IK=I IF(CLINE(I:I).NE.' ') GO TO 5 12 CONTINUE GO TO 9 5 FN2=INDEX(CLINE(IK:),' ')+IK-2 XB=FN2-IK+1 DECODE(XB,100,CLINE(IK:),ERR=91) N2 100 FORMAT(I) LND=FN2+1 DO 13 I=LND,80 IL=I IF(CLINE(I:I).NE.' ') GO TO 6 13 CONTINUE GO TO 9 6 FN3=INDEX(CLINE(IL:),' ')+IL-2 XB=FN3-IL+1 DECODE(XB,100,CLINE(IL:),ERR=91) N3 9 CONTINUE OPEN(UNIT=57,TYPE='OLD',SHARED,READONLY,ERR=2,NAME=CLINE(II:IE)) IF(N3.GT.0) PNTR=N3 IF(PNTR.GT.KNT) PNTR=KNT IF(N1.LE.0)N1=1 IF(N2.LE.0)N2=20000 LB=LN IF(PNTR.NE.KNT) THEN LB=3-LN IF(PNTR.NE.0) THEN DO 21 I=1,PNTR CALL ISETP(LB,I,IGETP(LN,I)) 21 CONTINUE END IF END IF IF(N1.GT.1) THEN NN=N1-1 DO 22 I=1,NN READ(57,101,END=91) 22 CONTINUE 101 FORMAT(A) END IF KK=PNTR DO 23 I=N1,N2 READ(57,101,END=24) REC(:LRECL) KK=KK+1 IWRT = IWRT+1 CALL ISETP(LB,KK,IWRT) CALL BWRITE(1,IWRT,REC(1:LRECL)) IF(KK.LT.BS) BS = BS+1 IF(KK.LT.BE) BE = BE+1 23 CONTINUE 24 CONTINUE IF(PNTR.LT.KNT) THEN JJ=PNTR+1 DO 25 I=JJ,KNT KK=KK+1 CALL ISETP(LB,KK,IGETP(LN,I)) 25 CONTINUE END IF LN=LB KNT=KK CLOSE (UNIT=57,DISP='SAVE',ERR=90) 90 RETURN 91 WRITE(6,910) ERRTST = .TRUE. 910 FORMAT(' BAD LINE NUMBER ON GET FILE COMMAND') GO TO 90 END SUBROUTINE GETLNO C C GETLNO WILL MOVE THE LINE POINTER TO THE C REQUESTED LINE NUMBER. C IMPLICIT INTEGER (A-Z) CHARACTER*255 MBLOK(7),CLINE,DELIM*1,REC,TMP LOGICAL MFLAG(7),PRINT,DOT,LINEM LOGICAL LINETMP COMMON /WORK/ MFLAG,LN,PNTR,LRECL,PRECL,PDL COMMON /ERRORS/ERRTST,OLPTR LOGICAL ERRTST INTEGER*4 OLPTR COMMON /VRFY/ PRINT,TAB,SAVE,DOT,LINEM COMMON /SMEM/ MBLOK,CLINE COMMON /FREE/ REC COMMON /FREE2/ TMP COMMON /ZONE/ ZS,ZE,BS,BE COMMON /TERM/ CC,LINES,IDAC,TPDL,LNO1,LNO2,KNT COMMON /WHERE/ IWRT INTEGER*4 IWRT ERRTST = .FALSE. IND=INDEX(CLINE,' ') DO 1 I=IND,80 II=I IF(CLINE(I:I).NE.' ') GO TO 3 1 CONTINUE 2 CONTINUE KR=PNTR IREC = IGETP(LN,KR) CALL BREAD(1,IREC,REC(1:LRECL)) LINETMP = LINEM LINEM = .TRUE. CALL PRINTIT(PNTR,REC(:LRECL)) LINEM = LINETMP 4 CONTINUE 5 CONTINUE RETURN 3 CONTINUE IND=INDEX(CLINE(II:),' ')-1 DECODE(IND,100,CLINE(II:II+IND-1),ERR=10) N IF(N.GT.KNT) GO TO 10 IF(N.LT.0) GO TO 10 PNTR=N GO TO 2 102 FORMAT(1X,I7,1X,A) 10 CONTINUE WRITE(6,101) ERRTST = .TRUE. 100 FORMAT(I) 101 FORMAT(' INVALID FORMAT ON GOTO COMMAND.REENTER') GO TO 5 END subroutine help(inline) COMMON /ERRORS/ERRTST,OLPTR LOGICAL ERRTST INTEGER*4 OLPTR character inline*(*) CHARACTER*80 OUTLINE,HLINE CHARACTER*80 UIN,UCMD character*1 ij ERRTST = .FALSE. OPEN (UNIT=17,NAME='SYS$HELP:CMEDIT.HLP',TYPE='OLD' 1 ,readonly,shared,ERR= 10000) 11000 FORMAT(Q,A) inq = len(inline) IF(INLINE .EQ. ' ') THEN !BASIC COMMAND C C READ LINES OF UNIT 1 AND OUTPUT UNTIL FIRST * C AFTER * PACK * LINES AND OUTPUT ONLY * LINES C 110 READ(17,11000,END=9000)LH,HLINE IF(HLINE(1:1).EQ.'*') THEN WRITE(6,12000) OUTLINE(1:) = HLINE(2:LH) LO = LH + 2 120 READ(17,11000,END=200)LH,HLINE IF(HLINE(1:1).NE.'*') GOTO 120 IF (LO+LH.GT.80) THEN WRITE(6,12100)OUTLINE(1:LO-2) LO = LH+2 OUTLINE(1:) = HLINE(2:LH) GOTO 120 ELSE OUTLINE(LO+1:LO+LH+1) = HLINE(2:LH) LO = LO+LH+2 GOTO 120 ENDIF 200 WRITE(6,12100)OUTLINE(1:LO-2) GOTO 9000 ELSE IF(HLINE(1:1).EQ.CHAR('21'X)) THEN GOTO 110 ELSE WRITE(6,12100)HLINE(1:LH) GOTO 110 ENDIF GOTO 9000 ELSE C C CONVERT REQUEST TO UPPERCASE C DO 205 I=1,INQ IJ = INLINE(I:I) IF(IJ.GE.'a'.and.ij.le.'z') ij = char(ichar(ij)-ichar('a') 1 +ichar('A')) 205 uin(i:i) = ij C C READ LINES OFF UNIT 17 UNTIL FIND *"COMMAND" C 210 READ(17,11000,END=300)LH,HLINE if(hline(1:1).eq.'*') then do 207 i= 1,lh ij = hline(i:i) if(ij.ge.'a'.and.ij.le.'z') ij = char(ichar(ij) 1 -ichar('a') +ichar('A')) 207 ucmd(i:i) = ij else goto 210 endif IF(UCMD(:MIN(LH,INQ+1)).EQ.'*'//UIN(1:INQ)) THEN WRITE(6,12200)HLINE(2:LH) 220 READ(17,11000,END=9000)LH,HLINE IF(HLINE(1:1).EQ.CHAR('21'X)) GOTO 220 IF(HLINE(1:1).EQ.'*')GOTO 9000 WRITE(6,12100)HLINE(:LH) GOTO 220 ELSE GOTO 210 ENDIF ENDIF GOTO 9000 300 write(6,12300)inline(1:inq) write(6,12000) outline = ' ' rewind 17 lo = 0 goto 120 9000 CONTINUE close(unit=17) return 12000 FORMAT(1H0,' The following subcommands are available'/) 12100 FORMAT(1X,A) 12200 FORMAT(1X,A) 12300 format(1h0,a,3x,'is not a subcommand') 10000 WRITE(6,12400) RETURN 12400 FORMAT(1H0,'Help not available at present') END SUBROUTINE HEXOCT(STRING,SIZE) C C A ROUTINE TO LOCATE AND CONVERT HEX OR OCTAL STRINGS C C THE SOURCE STRING IS OF THE FORM C /aaaaaaaa%"oooooo"%aaaaaa%'hhhhhhhh'%aaaaaaaa/ C WHERE: C / is any delimiter (other than % ' ") C aaaaaa is any set of characters C %" denotes an octal string follows if terminated by "% C %' denotes a hex string follows if terminated by '% C oooooo is an octal string (0-7) C hhhhhh is a hex string(0-F) CHARACTER*(*) STRING LOGICAL*1 WORK(255) INTEGER SIZE C CHECK TO SEE IF POSSIBLE HEX OR OCTAL STRING I1 = 1 100 I = INDEX(STRING(I1:),'%') IF(I.EQ.0) RETURN I1 = I1+I-1 C POSSIBLE EXISTS CHECK ON WHAT I = INDEX(STRING,'%''') IF(I.NE.0) THEN C POSSIBLE HEX STRING J = INDEX(STRING(I:),'''%') IF(J.EQ.0) GOTO 500 C HEX STRING PERHAPS VALID C N = J-3 IF(N.LT.1) GOTO 500 C NC = (N+1)/2 DECODE(N,11000,STRING(I+2:),ERR=500)(WORK(K),K=1,NC) C HEX STRING VALID NOW REBUILD STRING GOTO 300 ELSE C POSSIBLE OCTAL STRING I = INDEX(STRING,'%"') IF(I.EQ.0) GOTO 500 J = INDEX(STRING(I:),'"%') IF(J.EQ.0) GOTO 500 C OCTAL STRING PERHAPS VALID C N = J-3 IF(N.LT.1) GOTO 500 C NC = (N+2)/3 DECODE(N,11010,STRING(I+2:),ERR=500)(WORK(K),K=1,NC) ENDIF C VALID STRING DECODED INTO WORK C NOW REINCORPRATE INTO STRING 300 DO 310 K = 1,NC 310 STRING(K+I-1:K+I-1) = CHAR(WORK(K)) C NOW RESTORE THE REST OF THE STRING STRING(I+NC:) = STRING(I+J+1:)//' ' C C NOW RESET SEARCH POSITION ABOVE PREVIOUS SEARCH I1 = I+NC-1 C RESET SIZE TO NEW LIMITS SIZE = SIZE -J-1+NC 500 I1 = I1 + 1 GOTO 100 11000 FORMAT(Z2) 11010 FORMAT(O3) END SUBROUTINE INSERT C C INSERT WILL ALLOW INSERTION OF ONE OR A GROUP C OF LINES INTO A DATA SET; FOLLOWING THE LINE C PRESENTLY POINTED AT. C IMPLICIT INTEGER (A-Z) CHARACTER*255 MBLOK(7),CLINE,DELIM*1,REC,TMP LOGICAL MFLAG(7),PRINT,DOT,SINGLE COMMON /WORK/ MFLAG,LN,PNTR,LRECL,PRECL,PDL COMMON /VRFY/ PRINT,TAB,SAVE,DOT,LINEM COMMON /SMEM/ MBLOK,CLINE COMMON /FREE/ REC COMMON /FREE2/ TMP COMMON /ERRORS/ERRTST,OLPTR LOGICAL ERRTST INTEGER*4 OLPTR COMMON /ZONE/ ZS,ZE,BS,BE COMMON /TERM/ CC,LINES,IDAC,TPDL,LNO1,LNO2,KNT COMMON /WHERE/ IWRT COMMON /INNY/CQL,CQ(7),INC,ICST LOGICAL*1 B1(1) EQUIVALENCE (B1(1),REC(1:1)) INTEGER*4 IWRT INTEGER*4 GOIN GOIN = 0 ERRTST = .FALSE. IND = ICST IF(CLINE(ICST:ICST).EQ.' ') ICST = ICST + 1 CALL WORKTB SINGLE=.FALSE. DO 1 I=IND,135 II=I IF(CLINE(I:I).NE.' ') SINGLE=.TRUE. 1 CONTINUE PNTR = MAX(0,PNTR) SAV=PNTR LA=LN LB=3-LN IF(PNTR.GT.0) THEN DO 11 I=1,PNTR CALL ISETP(LB,I,IGETP(LA,I)) 11 CONTINUE END IF C C COPY LINES FROM 1 TO PNTR INTO ALTERNATE DATASET. C CHECK IF PNTR = 1 (SEE ABOVE) C THEN BEGIN READ INPUT LINES AFTER I> PROMPT C READ UNTIL END FILE (CNTL Z) C IF(SINGLE) THEN REC(:LRECL)=CLINE(ICST:) PNTR=PNTR+1 IWRT = IWRT+ 1 CALL ISETP(LB,PNTR,IWRT) IF(PNTR.LT.BS ) BS = BS + 1 IF(PNTR.LT.BE) BE = BE + 1 CALL BWRITE(1,IWRT,REC(1:LRECL)) ELSE 12 WRITE(6,104)PNTR+1 104 FORMAT('$',I6,'I>') C READ(5,103,END=13) NNN,REC(:LRECL) IF(GOIN.EQ.1) GOTO 13 CALL TTIN(REC,JJJ) IF(JJJ.LE.1) GOTO 13 IF(B1(JJJ).EQ.'1A'X.OR.B1(JJJ).EQ.'1B'X) THEN GOIN = 1 ENDIF REC(JJJ:) = ' ' NNN = JJJ-1 103 FORMAT(Q,A) IF(NNN.LE.0) GOTO 13 PNTR=PNTR+1 IWRT = IWRT + 1 CALL ISETP(LB,PNTR,IWRT) IF(PNTR.LT.BS) BS = BS + 1 IF(PNTR.LT.BE) BE = BE + 1 CLINE=REC(:LRECL) CQL = LRECL ICST = 1 CALL WORKTB REC(:LRECL) = CLINE(:LRECL) CALL BWRITE(1,IWRT,REC(1:LRECL)) GO TO 12 END IF C THEN COPY OTHER LINES INTO ALTERNATE FILE AND 13 CONTINUE IF(IWRT.LE.0) RETURN CALL BREAD(1,IWRT,REC(1:LRECL)) IF(SAV.EQ.PNTR) RETURN LN=LB N=PNTR-SAV SKNT=KNT KNT=KNT+N IF(SAV.EQ.SKNT) RETURN SAV=SAV+1 DO 14 I=SAV,SKNT 14 CALL ISETP(LB,I+N,IGETP(LA,I)) RETURN END SUBROUTINE LOCATE C C CMEDIT ROUTINE TO LOCATE STRINGS C FORMAT L /XXX/ C / IS THE DELIMITER CAN BE ANY CHARACTER C XXX IS THE STRING TO FIND C IMPLICIT INTEGER (A-Z) INTEGER WORK(80) CHARACTER*255 MBLOK(7),CLINE,DELIM*1,REC,TMP LOGICAL MFLAG(7),PRINT,DOT,LINEM COMMON /WORK/ MFLAG,LN,PNTR,LRECL,PRECL,PDL COMMON /CONY/ICONY COMMON /ERRORS/ERRTST,OLDPTR LOGICAL ERRTST INTEGER*4 OLDPTR COMMON /VRFY/ PRINT,TAB,SAVE,DOT,LINEM COMMON /SMEM/ MBLOK,CLINE COMMON /FREE/ REC COMMON /FREE2/ TMP COMMON /ZONE/ ZS,ZE,BS,BE COMMON /TERM/ CC,LINES,IDAC,TPDL,LNO1,LNO2,KNT COMMON /WHERE/ IWRT COMMON /INNY/CQL,CQ(7),INC,ICST INTEGER*4 IWRT C C LOCATE THE DELIMITERS C ERRTST = .FALSE. OLDPTR = PNTR 230 CONTINUE DO 3 M=ICST,80 DL1=M IF(CLINE(M:M).NE.' ') GO TO 4 3 CONTINUE M=0 C C BLANK CARD CHECK MEMORY FOR PREVIOUS CHANGE COMMAND. C IF(.NOT.MFLAG(5)) GO TO 80 CLINE=MBLOK(5) CQL = CQ(5) C C LOCATE DELIMITER C ICST = 1 DO 2 I = 1,20 IF(CLINE(I:I).LT.'A'.OR.CLINE(I:I).GT.'Z') GOTO 230 2 ICST = ICST + 1 GO TO 230 C C SET DEFAULT PARAMETERS C 4 ALL = 1 NLN=100000 OCCUR=0 DELIM=CLINE(DL1:DL1) DL2=INDEX(CLINE(DL1+1:),DELIM)+DL1 IF(DL2.EQ.DL1) DL2 = CQL + 1 IF(DL2.LE.DL1+1) GOTO 80 IF(CLINE(DL2+1:).EQ.' ') GO TO 20 SL=DL2+1 DO 7 II=SL,135 SL=SL+1 I=II K=1 IF(CLINE(I:I).EQ.' ') GO TO 7 IF(CLINE(I:I).EQ.'*') GO TO 10 IF(CLINE(I:I).EQ.'G') GOTO 8 IF(CLINE(I:I).EQ.'g') GOTO 8 6 IF(CLINE(I+K:I+K).EQ.' ') GO TO 9 K=K+1 GO TO 6 7 CONTINUE GO TO 20 8 NLN=100000 ALL = 100000 GO TO 20 9 DECODE(K,711,CLINE(I:I+K-1),ERR=88) LDUM 710 FORMAT(A) 711 FORMAT(I) NLN=LDUM 10 CONTINUE C C NOW DECODE SECOND HALF IF ANY C SL = I+K DO 17 II=SL,135 SL = SL+1 I = II IF(CLINE(I:I).EQ.' ')GOTO 17 IF(CLINE(I:I).EQ.'*') GOTO 18 IF(CLINE(I:I).EQ.'G') GOTO 18 K = 1 16 IF(CLINE(I+K:I+K).EQ.' ') GOTO 19 K = K+1 GOTO 16 17 CONTINUE GOTO 20 18 ALL = 100000 GOTO 20 19 DECODE(K,711,CLINE(I:I+K-1),ERR=88) LDUM ALL = LDUM 20 MBLOK(5)=CLINE CQ(5) = CQL MFLAG(5)=.TRUE. C C CALCULATE FIELD SIZES C 23 SZOLD=DL2-DL1-1 IF(SZOLD.EQ.0) GO TO 72 COUNT = 0 IFOUND = 0 CALL HEXOCT(CLINE(DL1+1:DL2-1),SZOLD) 40 CONTINUE OCCUR=0 ILOC=ZS C C TRY TO LOCATE OLD STRING IN RECORD C IF(PNTR+INC.GT.KNT.OR.PNTR+INC.LT.1) GOTO 70 COUNT = COUNT + 1 IF(COUNT.GT.NLN) GOTO 70 IF(ICONY.EQ.1) RETURN PNTR=PNTR+INC IREC = IGETP(LN,PNTR) CALL BREAD(1,IREC,REC(1:LRECL)) FIELD=INDEX(REC(ZS:ZE),CLINE(DL1+1:DL1+SZOLD)) IF(FIELD.EQ.0) GO TO 40 OLDPTR = PNTR OCCUR=OCCUR+1 IFOUND = IFOUND + 1 55 IF(OCCUR.GT.0) CALL PRINTIT(PNTR,REC(:LRECL)) 1000 FORMAT(1X,I7,1X,A) IF(IFOUND.GE.ALL) RETURN 68 GOTO 40 C 70 IF(IFOUND.EQ.0) GO TO 72 PNTR = OLDPTR IF(PNTR.NE.0) THEN IREC = IGETP(LN,PNTR) CALL BREAD(1,IREC,REC(1:LRECL)) ENDIF RETURN 72 NWRD=(SZOLD+2)/2 WRITE(6,75) CLINE(DL1+1:DL1+SZOLD) 75 FORMAT(' CANNOT FIND ',A) ERRTST = .TRUE. PNTR = OLDPTR IF(PNTR.NE.0) THEN IREC = IGETP(LN,PNTR) CALL BREAD(1,IREC,REC(1:LRECL)) ENDIF RETURN 80 WRITE(6,85) ERRTST = .TRUE. PNTR = OLDPTR IF(PNTR.NE.0) THEN IREC = IGETP(LN,PNTR) CALL BREAD(1,IREC,REC(1:LRECL)) ENDIF 85 FORMAT(' NO DELIMITER!') 86 RETURN 88 WRITE(6,100) ERRTST = .TRUE. PNTR = OLDPTR IF(PNTR.NE.0) THEN IREC = IGETP(LN,PNTR) CALL BREAD(1,IREC,REC(1:LRECL)) ENDIF 100 FORMAT(' INVALID OPERAND') GO TO 86 END SUBROUTINE MOVE C C MOVE WILL ALLOW INSERTION OF ONE OR A GROUP C OF LINES INTO A DATA SET; FOLLOWING THE LINE C PRESENTLY POINTED AT. C THE GROUP OF LINES WILL BE BETWEEN BS AND BE C C THE DUP WILL BE THE SAME AS MOVE EXCEPT WE C KEEP THE ORIGINAL BLOCK AND INCREASE KNT. C IMPLICIT INTEGER (A-Z) CHARACTER*255 MBLOK(7),CLINE,DELIM*1,REC,TMP LOGICAL MFLAG(7),PRINT,DOT,DUPE COMMON /WORK/ MFLAG,LN,PNTR,LRECL,PRECL,PDL COMMON /ERRORS/ERRTST,OLDPTR LOGICAL ERRTST INTEGER*4 OLDPTR COMMON /VRFY/ PRINT,TAB,SAVE,DOT,LINEM COMMON /SMEM/ MBLOK,CLINE COMMON /FREE/ REC COMMON /FREE2/ TMP COMMON /TERM/ CC,LINES,IDAC,TPDL,LNO1,LNO2,KNT COMMON /XORY/ X,Y COMMON /ZONE/ ZS,ZE,BS,BE COMMON /WHERE/ IWRT INTEGER*4 IWRT DATA DUPE/.FALSE./ 1 CONTINUE ERRTST = .FALSE. IF(BS.GT.BE) GO TO 50 IF(BS.LT.1) GO TO 50 IF(BS.GT.KNT) GO TO 50 IF(BS.LT.PNTR.AND.BE.GT.PNTR) GO TO 60 IF(BE.GT.KNT) GO TO 50 IF(BE.LT.1) GO TO 50 C C LOGIC TO RESET BS & BE C BEE = BE BSE = BS IF(.NOT.DUPE) THEN BSE = PNTR + 1 BEE = BE-BS+BSE ELSE IF(PNTR.LT.BS) THEN BSE = BE+1 BEE = BSE +BE-BS ENDIF C COPY LINES FROM 1 TO PNTR INTO ALTERNATE DATASET. C CHECK IF PNTR = 1 C THEN BEGIN READ INPUT LINES AFTER I> PROMPT C READ UNTIL END FILE (CNTL Z) C C THEN COPY OTHER LINES INTO ALTERNATE FILE AND C CHANGE KNT AND FILE POINTER C LB=3-LN BEP=BE+1 PN=PNTR+1 BSM=BS-1 IF(PNTR.LT.BS) THEN IF(PNTR.EQ.0) GO TO 210 DO 21 I=1,PNTR CALL ISETP(LB,I,IGETP(LN,I)) 21 CONTINUE 210 CONTINUE J=PNTR ELSE DO 22 I=1,BSM CALL ISETP(LB,I,IGETP(LN,I)) 22 CONTINUE J=BSM IF(DUPE) THEN DO 23 I=BS,BE J=J+1 IREC = IGETP(LN,I) CALL BREAD(1,IREC,REC(1:LRECL)) IWRT = IWRT + 1 CALL ISETP(LB,J,IWRT) CALL BWRITE(1,IWRT,REC(1:LRECL)) 23 CONTINUE END IF IF(BEP.GT.PNTR) GOTO 240 DO 24 I=BEP,PNTR J=J+1 CALL ISETP(LB,J,IGETP(LN,I)) 24 CONTINUE 240 CONTINUE END IF DO 25 I=BS,BE J=J+1 CALL ISETP(LB,J,IGETP(LN,I)) 25 CONTINUE IF(PNTR.LT.BE) THEN DO 26 I=PN,BSM J=J+1 CALL ISETP(LB,J,IGETP(LN,I)) 26 CONTINUE IF(DUPE) THEN DO 27 I=BS,BE J=J+1 IREC = IGETP(LN,I) CALL BREAD(1,IREC,REC(1:LRECL)) IWRT = IWRT + 1 CALL ISETP(LB,J,IWRT) CALL BWRITE(1,IWRT,REC(1:LRECL)) 27 CONTINUE END IF IF(BE.EQ.KNT) GO TO 280 DO 28 I=BEP,KNT J=J+1 CALL ISETP(LB,J,IGETP(LN,I)) 28 CONTINUE 280 CONTINUE ELSE IF(PNTR.EQ.KNT) GO TO 290 DO 29 I=PN,KNT J=J+1 CALL ISETP(LB,J,IGETP(LN,I)) 29 CONTINUE 290 CONTINUE END IF LN=LB KNT=J PNTR=PNTR+BE-BS+1 4 CONTINUE 5 DUPE=.FALSE. BS = BSE BE = BEE RETURN 50 CONTINUE DUPE=.FALSE. WRITE(6,51) BS,BE ERRTST = .TRUE. 51 FORMAT(' BLOCK NOT PROPERLY DEIFINED ',2I8) RETURN 60 CONTINUE DUPE=.FALSE. WRITE(6,61) BS,BE,PNTR ERRTST = .TRUE. 102 FORMAT(1X,A) 61 FORMAT(' PRESENT LINE WITHIN BLOCK ',3I8) RETURN ENTRY DUP DUPE=.TRUE. GO TO 1 END SUBROUTINE PUTFIL C C PUTFILE ROUTINE C IMPLICIT INTEGER (A-Z) CHARACTER*255 CLINE,MBLOK(7),REC,BLOK,NULL*1 LOGICAL MFLAG(7),X,Y,PRINT,TABS,DOT,LINEM COMMON /WORK/ MFLAG,LN,PNTR,LRECL,PRECL,PDL COMMON /FREE/ BLOK COMMON /ERRORS/ERRSTS,OLDPTR LOGICAL ERRTST INTEGER*4 OLDPTR COMMON /FREE2/ REC COMMON /VRFY/ PRINT,TABS,SAVE,DOT,LINEM COMMON /SMEM/ MBLOK,CLINE COMMON /XORY/ X,Y COMMON /TERM/ CC,LINES,IDAC,TPDL,LNO(2),KNT COMMON /ZONE/ ZSTART,ZEND,BS,BE COMMON /WHERE/ IWRT INTEGER*4 IWRT DATA NULL/0/ C C INITIALIZE VARIABLES C N1=0 ERRTST = .FALSE. N2=0 IE=80 IND=INDEX(CLINE,' ') DO 1 I=IND,80 II=I IF(CLINE(I:I).NE.' ') GO TO 3 1 CONTINUE 2 CONTINUE WRITE(6,2001) CLINE(II:IE) ERRTST = .TRUE. 2001 FORMAT(' BAD INPUT FILE NAME ON PUTFILE'/1X,A) GO TO 24 3 IE=INDEX(CLINE(II:),' ')+II-2 JND=IE+1 DO 11 I=JND,80 IJ=I IF(CLINE(I:I).NE.' ') GO TO 4 11 CONTINUE GO TO 9 4 FN1=INDEX(CLINE(IJ:),' ')+IJ-2 XB=FN1-IJ+1 DECODE(XB,100,CLINE(IJ:),ERR=91) N1 KND=FN1+1 DO 12 I=KND,80 IK=I IF(CLINE(I:I).NE.' ') GO TO 5 12 CONTINUE GO TO 9 5 FN2=INDEX(CLINE(IK:),' ')+IK-2 XB=FN2-IK+1 DECODE(XB,100,CLINE(IK:),ERR=91) N2 100 FORMAT(I) 9 CONTINUE OPEN(UNIT=57,TYPE='NEW',ERR=2,NAME=CLINE(II:IE), 1 CARRIAGECONTROL='LIST') IF(N1.EQ.0) N1=BS IF(N2.EQ.0) N2=BE IF(N1.LT.1) GO TO 91 IF(N1.GT.KNT) GO TO 91 IF(N1.GT.N2) GO TO 91 IF(N2.GT.KNT) GO TO 91 IF(N2.LT.1) GO TO 91 22 CONTINUE 101 FORMAT(A) DO 23 I=N1,N2 IREC = IGETP(LN,I) CALL BREAD(1,IREC,BLOK(1:LRECL)) DO 500 II =LRECL,1,-1 LNREC = II IF(BLOK(II:II).NE.' ') GOTO 510 500 CONTINUE 510 CONTINUE WRITE(57,101) BLOK(:LNREC) 23 CONTINUE 24 CONTINUE CLOSE (UNIT=57,DISP='SAVE',ERR=90) 90 RETURN 91 WRITE(6,910) ERRTST = .TRUE. 910 FORMAT(' BAD LINE NUMBER ON PUTFILE COMMAND') GO TO 90 END SUBROUTINE SETCALL IMPLICIT INTEGER(A-Z) COMMON /SMEM/ MBLOCK,CLINE COMMON /CALLS/ICALL,IIN LOGICAL ICALL CHARACTER*255 CLINE,MBLOCK(7) COMMON /INNY/ CQL,CQ(7),INC,ICST COMMON /ERRORS/ERRTST,OLDPTR LOGICAL ERRTST ERRTST = .FALSE. OPEN(UNIT=4,NAME=CLINE(ICST:CQL),TYPE='OLD',READONLY,SHARED, 1 ERR=5) IIN = 4 ICALL = .TRUE. RETURN C C ERROR C 5 CALL ERRSNS(IERR) IF(IERR.EQ.29) WRITE(6,*)' FILE: ',CLINE(ICST:CQL), 1 ' DOES NOT EXIST' IF(IERR.EQ.43) WRITE(6,*)' FILE: ',CLINE(ICST:CQL), 1 ' WAS BAD' IF(IERR.EQ.34) WRITE(6,*)' FILE: ',CLINE(ICST:CQL), 1 ' IS ALREADY OPEN' IF(IERR.NE.29.AND.IERR.NE.43.AND.IERR.NE.34) WRITE(6,*) 1 'OPEN FAILURE ERROR CODE= ',IERR ERRTST = .TRUE. RETURN END FUNCTION VERIFY(STRING1,STRING2) IMPLICIT INTEGER*4(A-Z) CHARACTER STRING1*(*),STRING2*(*) CHARACTER*1 TEST C C LOCATE FIRST CHARACTER IN STRING1 THAT DOES NOT C MATCH CHARACTER STRING2 LENN = LEN(STRING1) LENN2 = LEN(STRING2) DO 100 I=1,LENN VERIFY = I TEST = STRING1(I:I) DO 70 J=1,LENN2 IF(TEST.EQ.STRING2(J:J)) GOTO 100 70 CONTINUE RETURN 100 CONTINUE VERIFY = 0 RETURN END SUBROUTINE TABCHR CHARACTER*255 CLINE,MBLOK(7),REC,BLOK LOGICAL MFLAG(7),X,Y,PRINT,TABS,DOT,LINEM COMMON /WORK/ MFLAG,LN,PNTR,LRECL,PRECL,PDL COMMON /FREE/ REC COMMON /FREE2/ BLOK COMMON /ERRORS/ERRSTS,OLDPTR LOGICAL ERRTST INTEGER*4 OLDPTR COMMON /VRFY/ PRINT,TABS,SAVE,DOT,LINEM COMMON /SMEM/ MBLOK,CLINE COMMON /XORY/ X,Y COMMON /TERM/ CC,LINES,IDAC,TPDL,LNO(2),KNT COMMON /ZONE/ ZSTART,ZEND,BS,BE COMMON /WHERE/ IWRT COMMON /TABCM1/TCHAR COMMON /TABCM2/NTAB,ITAB(100) CHARACTER TCHAR*1 COMMON /INNY/CQL,CQ(7),INC,ICST INTEGER*4 IWRT C C SET TAB CHARACTER C C IF EMPTY COMMAND ECHO CURRENT CHARACTER AND STATUS IF OFF C TABS = .TRUE. ERRTST = .FALSE. IF(INC.LE.0) TABS = .FALSE. IF(CLINE(ICST:).EQ.' ') THEN ! BLANK COMMAND IF(TABS) THEN WRITE(6,12000)TCHAR ELSE WRITE(6,12010)TCHAR ENDIF ELSE ! NON BLANK COMMAND THEREFORE SET TCHAR DO 150 I=ICST,30 IF(CLINE(I:I).EQ.' ') GOTO 150 TCHAR = CLINE(I:I) GOTO 160 150 CONTINUE 160 CONTINUE ENDIF RETURN 12000 FORMAT(1X,'THE CURRENT LOGICAL TAB CHARACTER IS "',A1,'"') 12010 FORMAT(1X,'THE CURRENT LOGICAL TAB CHARACTER IS "',A1,'"', 1 10X,'TABS ARE DISABLED') END SUBROUTINE WORKTB IMPLICIT INTEGER(A-Z) CHARACTER*255 CLINE,MBLOCK(7) CHARACTER*255 WORK COMMON /SMEM/MBLOCK,CLINE COMMON /VRFY/ PRINT,TABS,SAVE,DOT,LINEM COMMON /INNY/CQL,CQ(7),INC,ICST COMMON /TABCM1/ TCHAR COMMON /TABCM2/ NTAB,ITAB(100) CHARACTER*1 TCHAR C C C REFORMAT CLINE TO APPEAR AS IF NO TABS C IF(.NOT.TABS)RETURN IF(NTAB.LE.0)RETURN IF(CQL.LT.ICST)RETURN WORK = ' ' C C NOW LOOP THROUGH INPUT CHARACTERS TO APPLY TABS LO = 1 LTAB = 1 DO 100 I=ICST,CQL IF(CLINE(I:I).EQ.TCHAR) THEN C C LOCATE NEXT TAB POSITION AND SETIT C DO 50 J=LTAB,NTAB IF(LO.GE.ITAB(J))GOTO 50 LO = ITAB(J) LTAB = J GOTO 60 50 CONTINUE 60 CONTINUE ELSE WORK(LO:LO) = CLINE(I:I) LO = LO+1 ENDIF IF(LO.GT.255) LO = 255 100 CONTINUE CQL = LO+ICST-2 CLINE(ICST:CQL) = WORK(:LO-1) RETURN END SUBROUTINE TABCMD CHARACTER*255 CLINE,MBLOK(7),REC,BLOK LOGICAL MFLAG(7),X,Y,PRINT,TABS,DOT,LINEM COMMON /WORK/ MFLAG,LN,PNTR,LRECL,PRECL,PDL COMMON /FREE/ REC COMMON /FREE2/ BLOK COMMON /VRFY/ PRINT,TABS,SAVE,DOT,LINEM COMMON /SMEM/ MBLOK,CLINE COMMON /ERRORS/ERRSTS,OLDPTR LOGICAL ERRTST INTEGER*4 OLDPTR COMMON /XORY/ X,Y COMMON /TERM/ CC,LINES,IDAC,TPDL,LNO(2),KNT COMMON /ZONE/ ZSTART,ZEND,BS,BE COMMON /WHERE/ IWRT COMMON /TABCM1/TCHAR COMMON /TABCM2/NTAB,ITAB(100) CHARACTER TCHAR*1 COMMON /INNY/CQL,CQ(7),INC,ICST INTEGER*4 IWRT INTEGER VERIFY C C SET TAB POSITIONS IF PRESENT C C ELSE SHO TAB POSITIONS C ERRTST = .FALSE. IF(CLINE(ICST:).EQ.' ') THEN ! SHOW THE TABS WRITE(6,12000)(ITAB(I),I=1,NTAB) 12000 FORMAT(1X,'TAB SETTINGS',/,(1X,15I4)) ELSE C C NOW BREAK OUT TAB POSITIONS C AND BUILD ARRAY C NTAB = 0 ITAB(1) = 0 IPOS = ICST 100 NST = VERIFY(CLINE(IPOS:),' ,') IF(NST.EQ.0) GOTO 1000 !NO MORE DATA IPOS = NST+IPOS-1 ISIZE = VERIFY(CLINE(IPOS:),'0987654321')-1 IF(ISIZE.LE.0) GOTO 9000 DECODE(ISIZE,12100,CLINE(IPOS:)) IVAL 12100 FORMAT(I) NTAB = NTAB+1 ITAB(NTAB) = IVAL IPOS = IPOS+ISIZE GOTO 100 ENDIF 1000 RETURN 9000 WRITE(6,12200) ERRTST = .TRUE. 12200 FORMAT(' ***ERROR*** BAD VALUE OR FORMAT ON TABSET') RETURN END SUBROUTINE XYCMD(*) C C XYCMD SETS UP THE X AND THE Y COMMAND SEQUENCES. C END OF LINE DELIMITER DEFAULT IS \ C PLACE OVERRIDE DELIMITER IN COLUMN 2 OF X OR Y DEFINE CARD C IMPLICIT INTEGER (A-Z) CHARACTER*1 TC CHARACTER*255 MBLOK(7),CLINE,DELIM*1,REC,TMP C ,XYC(20,2),DEL*1,CMD*1 LOGICAL MFLAG(7),PRINT,DOT,END,LAST,X,Y,L DIMENSION IXY(2) COMMON /WORK/ MFLAG,LN,PNTR,LRECL,PRECL,PDL COMMON /ERRORS/ERRTST,OLDPTR LOGICAL ERRTST INTEGER*4 OLDPTR COMMON /XORY/X,Y COMMON /VRFY/ PRINT,TAB,SAVE,DOT,LINEM COMMON /SMEM/ MBLOK,CLINE COMMON /FREE/ REC COMMON /FREE2/ TMP COMMON /ZONE/ ZS,ZE,BS,BE COMMON /TERM/ CC,LINES,IDAC,TPDL,LNO1,LNO2,KNT DATA IXY/0,0/,IC/1/,LAST/.FALSE./,L/.FALSE./ IF(L) GO TO 85 DEL='\' IF(X) JXY=1 IF(Y) JXY=2 IF(X) CMD='X' IF(Y) CMD='Y' REPEAT = 1 IF(CLINE(3:).EQ.' ') GO TO 75 IF(CLINE(2:2).NE.' ') THEN DEL = CLINE(2:2) CS = 3 GOTO 50 ENDIF C C THE COMMAND EITHER CONTAINS A REPEAT FACTOR OR IS A LOAD SEQ. C C FIND FIRST CHARACTER AFTER BLANKS DO 20 I = 3,130 CS = I TC = CLINE(I:I) IF(TC.EQ.' ') GOTO 20 IF(TC.GE.'A'.AND.TC.LE.'Z'.OR.TC.GE.'a'.AND.TC.LE.'z')GOTO 50 IF(TC.EQ.'-'.OR.TC.EQ.'.')GOTO 50 C C THERE MUST BE A DELIMITER OR A REPEAT FACTOR C GOTO 24 20 CONTINUE GOTO 75 C C NOW DIGEST FOR REPEAT FACTOR C 24 I = CS IF(TC.LE.'0'.OR.TC.GT.'9') GOTO 33 DO 30 J = I,I+6 TC = CLINE(J:J) IF(TC.EQ.'*')THEN REPEAT = 100000 GOTO 75 ENDIF K = J-I IF (TC.EQ.' ')GOTO 35 30 CONTINUE C C DELIMITER 33 DEL = TC CS = CS+1 C GOTO 50 C C NOW DECODE INTEGER C 35 DECODE(K,12000,CLINE(CS:CS+K-1),ERR=50)REPEAT 12000 FORMAT(I) GOTO 75 C C NOW LOAD COMMAND STRING C 50 IXY(JXY)=0 ERRTST = .FALSE. END=.FALSE. X=.FALSE. Y=.FALSE. 10 IF(INDEX(CLINE(CS:),DEL).EQ.0) END = .TRUE. IF(END.AND.CLINE(CS:135).EQ.' ')RETURN IXY(JXY)=IXY(JXY)+1 IN=INDEX(CLINE(CS:),DEL)-2 IF(IN.EQ.-2) IN=134-CS XYC(IXY(JXY),JXY)=CLINE(CS:CS+IN) CS=CS+IN+2 IF(.NOT.END) GO TO 10 RETURN 75 L=.TRUE. ERRTST = .FALSE. RETURN 85 CONTINUE IF(IXY(JXY).EQ.0) GO TO 80 IF(IC.GE.IXY(JXY)) LAST =.TRUE. IF(ERRTST) GOTO 802 CLINE=XYC(IC,JXY) IC=IC+1 IF(LAST) THEN REPEAT = REPEAT-1 IF(REPEAT.LE.0.OR.PNTR.GE.KNT.OR.ERRTST) THEN X=.FALSE. L=.FALSE. Y=.FALSE. ENDIF LAST=.FALSE. IC=1 END IF RETURN 80 CONTINUE WRITE(6,801) CMD ERRTST = .TRUE. 801 FORMAT(' ',A1,' COMMAND IS NOT DEFINED') 802 X = .FALSE. Y = .FALSE. L = .FALSE. RETURN 1 END SUBROUTINE XYLOAD C C THIS TESTS THE REPLACE MODE FOR SINGLE CARD. IMPLICIT INTEGER (A-Z) CHARACTER*255 CLINE,MBLOK(7),REC*255,BLOK*255 LOGICAL MFLAG(7),X,Y,PRINT,TABS COMMON /WORK/ MFLAG,LN,PNTR,LRECL,PRECL,PDL COMMON /FREE/ BLOK COMMON /FREE2/ REC COMMON /VRFY/ PRINT,TABS,SAVE COMMON /SMEM/ MBLOK,CLINE COMMON /XORY/ X,Y COMMON /TERM/ CC,LINES,IDAC,TPDL,LNO(2),KNT COMMON /ZONE/ ZSTART,ZEND ENTRY TRUNC ENTRY OVERLY ENTRY TERM ENTRY SHTMEM RETURN 777 CONTINUE DO 5 I=IND,135 II=I IF(CLINE(I:I).NE.' ') GO TO 50 5 CONTINUE DO 10 I=1,KNT II=I READ(UNIT'II) REC(:LRECL) WRITE(90,100) REC(:LRECL) 10 CONTINUE 100 FORMAT(A) 90 RETURN 50 CONTINUE C C WRITE THE EDITED DATA TO A NEW FILE. C IND=INDEX(CLINE(II:),' ')+II-2 C OPEN THE NEW FILE C OPEN (UNIT=3,TYPE='NEW',NAME=CLINE(II:IND), C RECORDSIZE=LRECL,RECORDTYPE='FIXED') DO 60 I=1,KNT KK=I READ(UNIT'KK) REC(1:LRECL) WRITE(3,100) REC(1:LRECL) 60 CONTINUE CLOSE(UNIT=3,DISP='KEEP') C C MESSAGE TO USER C WRITE(6,121) CLINE(II:IND) 121 FORMAT(' FILE WRITTEN TO ',A) GO TO 90 END SUBROUTINE ZONED C C PUTFILE ROUTINE C IMPLICIT INTEGER (A-Z) CHARACTER*255 CLINE,MBLOK(7),REC,BLOK,NULL*1 LOGICAL MFLAG(7),X,Y,PRINT,TABS,DOT,LINEM COMMON /WORK/ MFLAG,LN,PNTR,LRECL,PRECL,PDL COMMON /FREE/ BLOK COMMON /FREE2/ REC COMMON /VRFY/ PRINT,TABS,SAVE,DOT,LINEM COMMON /SMEM/ MBLOK,CLINE COMMON /XORY/ X,Y COMMON /TERM/ CC,LINES,IDAC,TPDL,LNO(2),KNT COMMON /ERRORS/ERRSTS,OLDPTR LOGICAL ERRTST INTEGER*4 OLDPTR COMMON /ZONE/ ZSTART,ZEND,BS,BE COMMON /WHERE/ IWRT INTEGER*4 IWRT DATA NULL/0/ C C INITIALIZE VARIABLES C N1=0 ERRTST = .FALSE. N2=0 IE=80 IND=INDEX(CLINE,' ') DO 1 I=IND,80 IJ=I IF(CLINE(I:I).NE.' ') GO TO 4 1 CONTINUE 2 CONTINUE WRITE(6,2001) CLINE(II:IE) ERRTST = .TRUE. 2001 FORMAT(' BAD FORMAT ON ZONE'/1X,A) RETURN 4 FN1=INDEX(CLINE(IJ:),' ')+IJ-2 XB=FN1-IJ+1 DECODE(XB,100,CLINE(IJ:),ERR=9) N1 KND=FN1+1 DO 12 I=KND,80 IK=I IF(CLINE(I:I).NE.' ') GO TO 5 12 CONTINUE GO TO 9 5 FN2=INDEX(CLINE(IK:),' ')+IK-2 XB=FN2-IK+1 DECODE(XB,100,CLINE(IK:),ERR=9) N2 100 FORMAT(I) 9 CONTINUE IF(N1.EQ.0) RETURN ZSTART = MIN(N1,LRECL) IF(N2.NE.0) ZEND = MIN(LRECL,N2) IF(N2.EQ.0) ZEND = LRECL RETURN END SUBROUTINE CCTRAP COMMON /CONY/ICONY COMMON /ERRORS/ERRTST,OLDPTR LOGICAL ERRTST INTEGER*4 OLDPTR ICONY = 1 RETURN END FUNCTION TTIN(STRING,LENGTH) EXTERNAL IO$_SETMODE,IO$M_CTRLCAST,IO$_READLBLK COMMON /CALLS/ICALL,IIN LOGICAL ICALL CHARACTER*40 NAME CHARACTER STRING*(*) INTEGER LENGTH,TTIN,TTCC INTEGER*2 IOSB(4) INTEGER*4 SYS$ASSIGN,SYS$QIOW INTEGER*2 TCHAN DATA IASS /0/ DATA TCHAN /0/ ITT = 1 10 IF(IASS.NE.0) GOTO 100 C C TRANSLATE TO SEE IF TERMINAL INPUT OR FILE C IASS = 1 ISTAT = SYS$TRNLOG('SYS$INPUT',N2,NAME,,,) IBEG = 1 IF (NAME(1:1).EQ.CHAR('1B'X))IBEG = 5 C C IF TERMINAL THEN TTxx: C K = INDEX(NAME(IBEG:),'TT') IF(K.EQ.0)GOTO 15 IF(NAME(IBEG+K+3:IBEG+K+3).NE.':')GOTO 15 C ASSIGN CHANNEL (SYS$INPUT) ISTAT = SYS$ASSIGN(NAME(IBEG:N2),TCHAN,,) IF(.NOT.ISTAT) STOP 'ERROR IN ASSIGNING SYS$INPUT' 15 GOTO (100,1000),ITT C C TTIN C 100 IF(ICALL) GOTO 150 IF(TCHAN.LE.0) GOTO 150 J = LEN(STRING) ISTAT =SYS$QIOW(,%VAL(TCHAN),IO$_READLBLK,IOSB,,,%REF(STRING) 1 ,%VAL(J),,,,) C C NOW SET LENGTH TO INCLUDE TERMINATOR C LENGTH = IOSB(2)+IOSB(4) C TTIN = ISTAT RETURN C C FILE INPUT SIMULATE TERMINAL ACTIVITY C 150 READ(IIN,11000,END=200),LENGTH,STRING 11000 FORMAT(Q,A) 160 LENGTH = LENGTH + 1 STRING(LENGTH:LENGTH) = CHAR('0D'X) TTIN = 1 RETURN 200 IF(IIN.NE.5) THEN ICALL = .FALSE. CLOSE(UNIT=IIN) IIN = 5 GOTO 10 ENDIF LENGTH = 4 STRING = 'FILE' GOTO 160 ENTRY TTCC(ROUTINE) ITT = 2 IF (IASS.EQ.0) GOTO 10 C C NOW SET UP FOR CONTROL C TRAPS C 1000 IF(TCHAN.LE.0) THEN TTCC = 1 RETURN ENDIF IOCODE = IOR(%LOC(IO$_SETMODE),%LOC(IO$M_CTRLCAST)) ISTAT = SYS$QIOW(,%VAL(TCHAN),%VAL(IOCODE),,,,ROUTINE,,,,,) TTCC = ISTAT RETURN END FUNCTION ISETP(LN,PNTR,IREC) IMPLICIT INTEGER*4 (A-Z) LOGICAL*1 II(4) CHARACTER*4 IC EQUIVALENCE (II(1),IC(1:1)) EQUIVALENCE(II,I) PARAMETER IS =2 PARAMETER LIM =64200 PARAMETER LIM2 =2*LIM, LIM3 = 3*LIM, LIM4 = 4*LIM, LIM5 = 5*LIM C C THIS ROUTINE CONTAINS THE POINTER STRUCTURE FOR THE WORK FILE C CHARACTER*(IS) CBUF(LIM*2) DIMENSION IOFFA(6) DATA IOFFA /0,LIM,LIM2,LIM3,LIM4,LIM5/ DATA IFATAL /0/ IF(PNTR.LE.0) PNTR = 1 IF (PNTR.GT.LIM) THEN C FATAL ERROR TOO MANY RECORDS IN DATA BASE ISETP = 0 IF(IFATAL.EQ.1) WRITE(6,12000) IFATAL = 1 12000 FORMAT(1X,'TOO MANY RECORDS - USE BIGCM OR BREAK UP FILE') ISETP = 0 RETURN ENDIF C ALL IS OK SO STORE RECORD VALUE IN PNTR CELL IOFF =IOFFA(LN) I = IREC CBUF (IOFF+PNTR) = IC(1:IS) RETURN ENTRY IGETP(LN,PNTR) IF(PNTR.LE.0) PNTR = 1 IOFF= IOFFA(LN) I = 0 IC(1:IS) = CBUF(IOFF+PNTR) IGETP = I RETURN END subroutine bread(iunit,irec,rec) character rec*(*) read(iunit'irec)rec return end subroutine bwrite(iunit,irec,rec) character rec*(*) write(iunit'irec)rec return end SUBROUTINE PRINTIT(PNTR,REC) IMPLICIT INTEGER*4 (A-Z) CHARACTER REC*(*) INTEGER*4 PNTR COMMON /PSIZE/ICSTART,ICEND C C NOW FIT REC INTO BUFFER ICSTART TO ICEND C C NOTE ICSTART DEF 1 ICEND DEF LRECL C CHARACTER*512 BUF CHARACTER*255 BLANK COMMON /VRFY/ PRINT ,TAB, SAVE, DOT,LINEM LOGICAL PRINT,TAB,SAVE,DOT,LINEM DATA BLANK /' '/ IF(.NOT.PRINT) RETURN L = LEN(REC) L = MIN(ICEND,L) IF (L.LT.ICSTART) THEN BUF = ' ' ELSE BUF = REC(ICSTART:L) ENDIF J = INDEX(BUF,BLANK) IF(LINEM) THEN WRITE(6,12000)PNTR,BUF(1:J) ELSE WRITE(6,12005)BUF(1:J) 12005 FORMAT(1X,A) ENDIF 12000 FORMAT(1X,I7,1X,A) RETURN END SUBROUTINE PZONE IMPLICIT INTEGER*4 (A-Z) COMMON /PSIZE/ICSTART,ICEND COMMON /INNY/CQL,CQ(7),INC,ICST COMMON /WORK/MFLAG,LN,PNTR,LRECL,PRECL,PDL LOGICAL MFLAG(7) CHARACTER*255 CLINE,MBLOK(7) COMMON /SMEM/MBLOK,CLINE COMMON /ERRORS/ERRTST,OLPTR LOGICAL ERRTST C C FIND IF ANY ARGUMENTS C DO 10 I=ICST,CQL IF(CLINE(I:I).EQ.' ')GOTO 10 J = I GOTO 20 10 CONTINUE C C BLANK CARD C ICSTART = 1 ICEND = LRECL RETURN 20 CONTINUE C C THERE IS SOMETHING FOR LINE C JJ = INDEX(CLINE(J+1:),' ') IF(JJ.EQ.0) JJ=1 DECODE(JJ,50,CLINE(J:J+JJ-1),ERR=80)ICSTART IF(ICSTART.GT.LRECL)ICSTART = 1 C C ANYTHING MORE ON LINE C ICEND = LRECL IF(J+JJ.GE.CQL) RETURN I = VERIFY(CLINE(J+JJ:CQL),' ') IF(I.EQ.0)RETURN J = I+J+JJ-1 JJ = INDEX(CLINE(J+1:CQL),' ') IF(JJ.EQ.0)JJ = CQL-J+1 DECODE(JJ,50,CLINE(J:J+JJ-1),ERR=80)ICEND IF(ICEND.GT.LRECL)ICEND = LRECL 50 FORMAT(I) RETURN 80 WRITE(6,12000) 12000 FORMAT(1X,' ILLEGAL FORMAT ON PZONE') ERRTST = .TRUE. RETURN END