C C Title: ReGIS to HP-GL Conversion Program C C Routine Name: RHP C C File Name: RHP.FTN C C Author: N. Hoult C C Description: C C This routine converts a file of ReGIS commands into HP-GL C commands for the 7470A plotter, which it drives down the HPIB C interface. The plotter should be set to 'listen only' mode C (i.e. HPIB address 31); the computer HPIB address is assumed C to be 9. If this is not the case, edit parameter COMADR in C routine IEEE (in this file) appropriately. Any ReGIS command is C accepted, only the following are interpreted: C C S(E) - Interpreted as end of plot. Program pauses C for paper to be changed C C S(A[..][..])- Interpreted as for VT125 C C W(F..) - Interpreted as pen select. Note that pen 1 and C pen 3 produce the same results. C C W(P..) - Select writing pattern. Pattern 1 (the default) C is a solid line, but the other numbers do not C necessarily correspond to the same patterns as C on the VT125. The form W(P10110) is not accepted. C C W(P(M..)) - Set pattern multiplier C C T(S..) - Text size, as for VT125 C C T'...' C OR T"..." - Text, as for VT125 C C P[..][..].. - Cursor move, as for VT125. Both absolute and C relative moves are allowed, but x and y must be C both absolute or both relative: a warning message C is printed if not. Both this and the V command C may be split between coordinate pairs to occupy C several lines; other commands may not be split. C C V[..][..].. - Vector command. See comments above. C C Modification List: C 1.A Date: 12-Nov-84 ORIGINAL C 1.B Date: 15-Nov-84 Correct text position, ignore carr. ctl. chars C 1.C Date: 16-Nov-84 Trap HPIB errors C 1.D Date: 20-Nov-84 Take command line C 1.E Date: 26-Nov-84 Better parsing - take macrographs C 1.F Date: 29-Nov-84 Better parsing - take T'...' '...' C 1.G Date: 07-Dec-84 Accept W(P...) C 1.H Date: 20-Mar-85 Fix bug with zero-length input lines C 1.I Date: 17-Apr-85 Fix bugs with pattern control + absence of C carriage controls C 1.J Date: 12-Dec-85 Make HPIB address a parameter C C Restrictions: Maximum macrograph length, and maximum length of C a line after interpreting macrographs, is 1000 chars. C C Calling Sequence: Connect plotter to HPIB, type RHP C C External Routines called: GETCDS, IPOS, LENGTH, ERRISB, ERRDSW C C Common Blocks: None C CEND C LOGICAL REGIS,DRWING,RELPLT,XREL,YREL,ERROR,EOF BYTE BUFFER(1000),FILE(37),COMD(140),TEMP(80),ESC,CQT,INBUF(140) DATA LUNIE,LUNFIL,LUNCMD,LUNTI,LUNTO/1,2,4,5,6/ C C Identify C WRITE (LUNTO,1) 1 FORMAT(' RHP -- Issue: 1.J Date: 12-Dec-85') C C Set variables C REGIS=.FALSE. DRWING=.FALSE. RELPLT=.FALSE. SIZE=1. IPEN=0 XSENS=1. YSENS=-1. IPM=2 IPAT=1 CALL FLGINI C C Initialise interface C CALL IEEINI(LUNIE) CALL IEEWRT(LUNIE,'IN;IP100,670,10200,6980;IW90,660,10210,6990;') CALL IEEWRT(LUNIE,'SC0,767,479,0;SI0.20,0.33;') C C Open file C CALL GETCDS(LUNCMD,'ReGIS Input File []> ',FILE,37,LEN, 1 'SY:DATA.RGS',.TRUE.) OPEN (UNIT=LUNFIL,FILE=FILE,STATUS='OLD',READONLY,SHARED) C C Main loop C C Read a line C 10 READ (LUNFIL,990,END=80) INLENG,INBUF 990 FORMAT(Q,140A1) C !1.H C If zero length, get another line !1.H C !1.H IF (INLENG.EQ.0) GOTO 10 !1.H C C Strip spaces, tabs, nulls and non-Regis text C CALL RGSLNE(INBUF,INLENG) C C Interpret macrographs C CALL MGRAPH(INBUF,INLENG,BUFFER,LENG) IPOINT=1 C C Get commands C 20 CONTINUE IF (IPOINT.GT.LENG) GOTO 10 !Finished this line D WRITE (LUNTO,6000) IPOINT, D 1 (BUFFER(I),I=MIN(IPOINT,LENG),MIN(IPOINT+19,LENG)) D6000 FORMAT(' * IPOINT=',I3,' BUFFER="',20A1,'..."') C C Look for a ReGIS command C CALL COMAND(BUFFER,LENG,IPOINT,COMD,LENCMD) IF (LENCMD.EQ.0) GOTO 10 !No command found C IF (COMD(1).EQ.'S') THEN C C S command -- Interpret S(E) as pause to change paper, C S(A[u,v][x,y]) as set mapping C I=IPOS(COMD,,1HE,1) IF (I.NE.0) THEN CALL IEEWRT(LUNIE,'SP;') CALL READY(LUNTI,LUNTO,EOF) IF (EOF) GOTO 80 IF (IPEN.NE.0) THEN ENCODE(7,995,TEMP) IPEN,0 995 FORMAT('SP',I3,';',A1) CALL IEEWRT(LUNIE,TEMP) ENDIF ENDIF I=IPOS(COMD,,2HA[,2) IF (I.NE.0) THEN CALL COORDS(COMD,LENCMD,I,IXTL,IYTL,XREL,YREL,ERROR) IF (ERROR) GOTO 30 CALL COORDS(COMD,LENCMD,I,IXBR,IYBR,XREL,YREL,ERROR) IF (ERROR) GOTO 30 XSENS=1. YSENS=1. IF (IXBR.LT.IXTL) XSENS=-1. IF (IYTL.LT.IYBR) YSENS=-1. ENCODE (27,1010,TEMP) IXTL,IXBR,IYBR,IYTL,0 1010 FORMAT('SC',I5,',',I5,',',I5,',',I5,';',A1) CALL IEEWRT(LUNIE,TEMP) ENDIF 30 CONTINUE ELSE IF (COMD(1).EQ.'W') THEN C C W Command -- only interpret W(Fn) as pen select, W(Pn) as select C pattern and W(P(Mn)) as set multiplier C I=IPOS(COMD,LENCMD,1HF,1) IF (I.NE.0) THEN I=I+1 CALL VALUE(COMD,LENCMD,I,J,ERROR) IF (.NOT.ERROR) THEN IPEN=J ENCODE(10,1020,TEMP) J,0 1020 FORMAT('PU;SP',I3,';',A1) DRWING=.FALSE. CALL IEEWRT(LUNIE,TEMP) ENDIF ENDIF J=1 IPATT=IPAT IPMT=IPM 31 I=IPOS(COMD(J),LENCMD-J,1HP,1)+J-1 IF (I.EQ.J-1) GOTO 32 !No W(P... J=I+1 !COMD(J) is char after P D WRITE (LUNTO,1021) J,COMD(J) D1021 FORMAT(' ** COMD(',I3,')=',A1,I3) IF (COMD(J).EQ.'(') THEN D WRITE (LUNTO,1022) D1022 FORMAT(' ** PROCESSING W(P(..)') K=IPOS(COMD(J),LENCMD+1-J,1H),1)+J-1 IF (K.GT.J+2) THEN IF (COMD(J+1).EQ.'M') THEN CALL VALUE(COMD,LENCMD,J+2,I,ERROR) IF (.NOT.ERROR) IPMT=I ENDIF ENDIF ELSE IF (COMD(J).GE.'0' .AND. COMD(J).LE.'9') THEN D WRITE (LUNTO,1023) D1023 FORMAT(' ** PROCESSING W(Pnnn)') CALL VALUE(COMD,LENCMD,J,I,ERROR) IF (.NOT.ERROR .AND. I.LT.10) IPATT=I ENDIF GOTO 31 32 IF (IPMT.NE.IPM .OR. IPATT.NE.IPAT) THEN IPAT=IPATT IPM=IPMT IF (IPATT.NE.1) THEN !1.I ENCODE (9,1032,TEMP) IPATT-1,IPMT*0.9,0 1032 FORMAT('LT',I1,',',F3.1,';',A1) ELSE !1.I ENCODE (4,1033,TEMP) 0 !1.I 1033 FORMAT('LT;',A1) !1.I ENDIF !1.I CALL IEEWRT(LUNIE,TEMP) ENDIF ELSE IF (COMD(1).EQ.'T') THEN C C T Command -- look for T(Sn) and T'.......'/T"......." C I=IPOS(COMD,LENCMD,1H(,1) J=IPOS(COMD,LENCMD,1H',1) K=IPOS(COMD,LENCMD,1H",1) IF (K.NE.0 .AND. (J.EQ.0 .OR. K.LT.J)) THEN J=K CQT=1H" ELSE CQT=1H' ENDIF IF (I.NE.0 .AND. (J.EQ.0 .OR. I.LT.J) .AND. 1 COMD(I+1).EQ.'S') THEN C C Command is T(Snn) C I=I+2 CALL VALUE(COMD,LENCMD,I,ISIZ,ERROR) IF (.NOT.ERROR) THEN SIZE=ISIZ IF (ISIZ.EQ.0) SIZE=0.5 ENCODE(17,1030,TEMP) 0.2*SIZE,0.33*SIZE,0 1030 FORMAT('SI',F6.3,',',F6.3,';',A1) CALL IEEWRT(LUNIE,TEMP) ENDIF ENDIF IF (J.NE.0) THEN C C Command is T'...' or T"..." C K=IPOS(COMD(J+1),LENCMD-J,CQT,1)+J IF (K.NE.0 .AND. K.NE.J+1) THEN ENCODE(17,1035,TEMP) XSENS*SIZE*1.5,-YSENS*SIZE*15,0 1035 FORMAT('PR;PU',F4.1,',',F5.0,';',A1) CALL IEEWRT(LUNIE,TEMP) RELPLT=.TRUE. DRWING=.FALSE. ENCODE(K-(J+1)+4,1040,TEMP) (COMD(L),L=J+1,K-1),3,0 1040 FORMAT('LB',A1,2A1) CALL IEEWRT(LUNIE,TEMP) ENCODE(14,1045,TEMP) XSENS*SIZE*1.5,YSENS*SIZE*15,0 1045 FORMAT('PU',F4.1,',',F5.0,';',A1) CALL IEEWRT(LUNIE,TEMP) ENDIF ENDIF ELSE IF (COMD(1).EQ.'P') THEN C C P Command -- check for absolute or relative C IPT=1 CALL COORDS(COMD,LENCMD,IPT,IXPOS,IYPOS,XREL,YREL,ERROR) IF (ERROR) GOTO 50 IF (XREL .AND. YREL) THEN IF (.NOT.RELPLT) CALL IEEWRT(LUNIE,'PR;') RELPLT=.TRUE. ELSE IF (.NOT.XREL .AND. .NOT.YREL) THEN IF (RELPLT) CALL IEEWRT(LUNIE,'PA;') RELPLT=.FALSE. ELSE WRITE (LUNTO,3000) 3000 FORMAT(' ** WARNING ** Mixed relative/absolute position') ENDIF ENCODE(15,1050,TEMP) IXPOS,IYPOS,0 1050 FORMAT('PU',I5,',',I5,';',A1) CALL IEEWRT(LUNIE,TEMP) 50 DRWING=.FALSE. ELSE IF (COMD(1).EQ.'V') THEN C C V Command -- check for absolute or relative C IPT=1 CALL COORDS(COMD,LENCMD,IPT,IXPOS,IYPOS,XREL,YREL,ERROR) IF (ERROR) GOTO 70 IF (XREL .AND. YREL) THEN IF (.NOT.RELPLT) CALL IEEWRT(LUNIE,'PR;') RELPLT=.TRUE. ELSE IF (.NOT.XREL .AND. .NOT.YREL) THEN IF (RELPLT) CALL IEEWRT(LUNIE,'PA;') RELPLT=.FALSE. ELSE WRITE (LUNTO,3000) ENDIF ENCODE(15,1060,TEMP) IXPOS,IYPOS,0 1060 FORMAT('PD',I5,',',I5,';',A1) CALL IEEWRT(LUNIE,TEMP) 70 DRWING=.TRUE. ELSE WRITE (LUNTO,3100) (COMD(I),I=1,LENCMD) 3100 FORMAT(' *** Unrecognised command "',A1,'"') ENDIF C C Get next command C GOTO 20 C C End of file C 80 CALL IEEWRT(LUNIE,'SP;') CALL IEEEXI(LUNIE) CLOSE (UNIT=LUNFIL) STOP END SUBROUTINE COMAND(LINE,LENG,POINT,COMD,LENCMD) INTEGER START,END,POINT,SBRCNT,RBRCNT LOGICAL QUOTE,LLOAD BYTE LINE(*),COMD(*),CHAR,CQT,FSTCHR C C Check if anything to process C LENCMD=0 COMD(1)=0 LLOAD=.FALSE. IF (POINT.GE.LENG) RETURN C C Skip to valid command C DO 1 I=POINT,LENG IF (LINE(I).EQ.'W' .OR. LINE(I).EQ.'S' .OR. LINE(I).EQ.'T' 1 .OR.LINE(I).EQ.'P' .OR. LINE(I).EQ.'V' .OR. LINE(I).EQ.'C' 2 .OR.LINE(I).EQ.'L' .OR. LINE(I).EQ.'R') GOTO 2 IF (LINE(I).EQ.'[' .OR. LINE(I).EQ.'(' .OR. LINE(I).EQ.1H' 1 .OR.LINE(I).EQ.1H") GOTO 3 1 CONTINUE RETURN 2 FSTCHR=LINE(I) I=I+1 IF (I.GT.LENG) RETURN 3 POINT=I D TYPE 6020,I D6020 FORMAT(' ** FOUND VALID COMMAND AT POINT=',I5) C C Initialise variables C START=POINT SBRCNT=0 RBRCNT=0 QUOTE=.FALSE. C C Set flag for L"... command (only terminated by ;) C LLOAD=FSTCHR.EQ.'L' .AND. LINE(POINT).EQ.1H" C C Read command till we have had either ', (, or [ and until C the number of '/" is even AND the number of ( = number of ) C AND number of [ = number of ] OR until an unquoted ; C 10 CHAR=LINE(POINT) IF (CHAR.EQ.'(') THEN RBRCNT=RBRCNT+1 ELSE IF (CHAR.EQ.')') THEN RBRCNT=RBRCNT-1 ELSE IF (CHAR.EQ.'[') THEN SBRCNT=SBRCNT+1 ELSE IF (CHAR.EQ.']') THEN SBRCNT=SBRCNT-1 ELSE IF ((CHAR.EQ.1H' .OR. CHAR.EQ.1H") .AND. .NOT.QUOTE) THEN QUOTE=.TRUE. CQT=CHAR ELSE IF (CHAR.EQ.CQT .AND. QUOTE) THEN QUOTE=.FALSE. ENDIF POINT=POINT+1 C C Terminate any command at end of line C IF (POINT.GT.LENG) GOTO 15 C C Terminate any command at unquoted semicolon C IF (LINE(POINT).EQ.';' .AND. .NOT.QUOTE) GOTO 15 C C For L"... command, this is only terminator C IF (LLOAD) GOTO 10 C C Otherwise, carry on till brackets and quotes match C IF (QUOTE .OR. RBRCNT.NE.0 .OR. SBRCNT.NE.0) GOTO 10 15 END=POINT-1 LENCMD=END-START+1 IF (LENCMD.LE.0) THEN LENCMD=0 RETURN ENDIF COMD(1)=FSTCHR DO 20 I=0,LENCMD-1 COMD(I+2)=LINE(START+I) 20 CONTINUE LENCMD=LENCMD+1 COMD(LENCMD+1)=0 D TYPE 1000,(COMD(I),I=1,LENCMD) D1000 FORMAT(' * COMMAND IS "',A1,'"') RETURN END SUBROUTINE IEEE(LUNIE,BUFFER) BYTE BUFFER(*) BYTE TLKCMD(2),RENCMD INTEGER*2 IPRM(6),IOSB(2),COMADR,COMREN,COMTLK !1.J LOGICAL ERRISB,ERRDSW C C Change this if your computer HPIB address is not 9 C PARAMETER (COMADR=9) !1.J C PARAMETER (COMREN=COMADR+"60,COMTLK=COMADR+"120)!1.J DATA RENCMD/COMREN/ !1.J Remote enable computer DATA TLKCMD/"77,COMTLK/ !1.J Unlisten, computer 'my talk address' DATA LUNERR,LUNTO/3,6/ RETURN C C IEEINI -- Attach and initialise interface C ENTRY IEEINI(LUNIE) INCLUDE 'LB:[1,1]IECIO.FTN' D WRITE (5,1000) D1000 FORMAT(' * Initialising interface') D IF (.TRUE.) RETURN CALL ASSIGN(LUNIE,'IE:') C C Attach interface C CALL WTQIO(IOFATC,LUNIE,LUNIE,,IOSB,,IDSW) IF (ERRDSW(LUNTO,IDSW,LUNERR,'Failed to attach IE:')) GOTO 20 IF (ERRISB(LUNTO,IOSB,LUNERR,'Failed to attach IE:')) GOTO 20 C C Remote enable computer (plotter doesn't have local mode) C CALL GETADR(IPRM(1),RENCMD) IPRM(2)=1 IPRM(3)=0 IPRM(4)=0 IPRM(5)=0 IPRM(6)=0 CALL WTQIO(IOFREN,LUNIE,LUNIE,,IOSB,IPRM,IDSW) IF (ERRDSW(LUNTO,IDSW,LUNERR,'Failed to remote enable')) GOTO 10 IF (ERRISB(LUNTO,IOSB,LUNERR,'Failed to remote enable')) GOTO 10 C C Set computer as talker C CALL GETADR(IPRM(1),TLKCMD) IPRM(2)=2 IPRM(3)=0 IPRM(4)=0 IPRM(5)=0 IPRM(6)=0 CALL WTQIO(IOFCTS,LUNIE,LUNIE,,IOSB,IPRM,IDSW) IF (ERRDSW(LUNTO,IDSW,LUNERR,'Failed to send talk command')) 1 GOTO 10 IF (ERRISB(LUNTO,IOSB,LUNERR,'Failed to send talk command')) 1 GOTO 10 RETURN C C Entry IEEWRT -- Write a command C ENTRY IEEWRT(LUNIE,BUFFER) CALL GETADR(IPRM(1),BUFFER) IPRM(2)=LENGTH(BUFFER) IPRM(3)=0 IPRM(4)=0 IPRM(5)=0 IPRM(6)=0 D LEN=IPRM(2) D WRITE (6,1010) (BUFFER(I),I=1,LEN) D1010 FORMAT(' * Writing "',A1,'"') D IF (.TRUE.) RETURN CALL WTQIO(IOFWLB,LUNIE,LUNIE,,IOSB,IPRM,IDSW) IF (ERRDSW(LUNTO,IDSW,LUNERR,'Failed to send command')) GOTO 10 IF (ERRISB(LUNTO,IOSB,LUNERR,'Failed to send command')) GOTO 10 RETURN C C Entry IEEEXI -- Detach interface C ENTRY IEEEXI(LUNIE) D WRITE (6,1020) D1020 FORMAT(' * Freeing interface') D IF (.TRUE.) RETURN CALL WTQIO(IOFDET,LUNIE,LUNIE,,,,IDSW) IF (ERRDSW(LUNTO,IDSW,LUNERR,'Failed to detach IE:')) CONTINUE RETURN C C Error handling C 10 CALL WTQIO(IOFKIL,LUNIE,LUNIE,,,,IDSW) IF (ERRDSW(LUNTO,IDSW,LUNERR,'Failed kill I/O')) CONTINUE CALL WTQIO(IOFDET,LUNIE,LUNIE,,,,IDSW) IF (ERRDSW(LUNTO,IDSW,LUNERR,'Failed to detach IE:')) CONTINUE 20 STOP 'HPIB ERROR' END SUBROUTINE READY(LUNTI,LUNTO,EOF) C C Prompt at terminal (not command file) C LOGICAL EOF EOF=.FALSE. WRITE (LUNTO,1000) 1000 FORMAT(' RHP -- Load paper, type to continue ',$) READ (LUNTI,1010,END=10,ERR=10) 1010 FORMAT(1X) RETURN 10 EOF=.TRUE. RETURN END SUBROUTINE RGSLNE(LINE,LENG) BYTE LINE(*),EP(2),EB(2),CQT,TAB,NULL,ESC !1.I LOGICAL RGS,QUOTE INTEGER OUTPT PARAMETER (ESC=27) DATA EP/ESC,'P'/,EB/ESC,'\'/,NULL,TAB/0,9/ SAVE INPT=1 C C Strip off top bit C DO 5 I=1,LENG LINE(I)=LINE(I).AND."177 5 CONTINUE C C Skip leading carriage control C IF (LINE(1).EQ.NULL .OR. LINE(1).EQ.' ' .OR. LINE(1).EQ.'$' 1 .OR. LINE(1).EQ.'0' .OR. LINE(1).EQ.'1') INPT=2 OUTPT=0 10 IF (RGS) THEN ISTART=INPT ELSE ISTART=IPOS(LINE(INPT),LENG+1-INPT,EP,2) IF (ISTART.NE.0) ISTART=IPOS(LINE(INPT+ISTART-1), 1 LENG+2-INPT-ISTART,1Hp,1)+INPT+ISTART-1 ENDIF IF (ISTART.EQ.0) THEN GOTO 30 ELSE IF (ISTART.LE.LENG) THEN IEND=IPOS(LINE(ISTART),LENG+1-ISTART,EB,2)+ISTART-2 IF (IEND.EQ.ISTART-2) IEND=LENG IF (IEND.GE.ISTART) THEN DO 20 I=ISTART,IEND IF ((LINE(I).EQ.1H' .OR. LINE(I).EQ.1H") .AND. .NOT.QUOTE) 1 THEN QUOTE=.TRUE. CQT=LINE(I) ELSE IF (LINE(I).EQ.CQT .AND. QUOTE) THEN QUOTE=.FALSE. ENDIF IF (LINE(I).NE.NULL .AND. LINE(I).NE.3 .AND. 1 (QUOTE .OR. (LINE(I).NE.TAB .AND. LINE(I).NE.' '))) 2 THEN OUTPT=OUTPT+1 LINE(OUTPT)=LINE(I) IF (LINE(OUTPT).GE.'a' .AND. LINE(OUTPT).LE.'z' .AND. 1 .NOT.QUOTE) LINE(OUTPT)=LINE(OUTPT).AND..NOT."40 ENDIF 20 CONTINUE ENDIF ENDIF IF (IEND.GE.LENG .OR. ISTART.GE.LENG) THEN RGS=.TRUE. GOTO 30 ELSE RGS=.FALSE. IF (IEND.LE.INPT) GOTO 30 !1.I INPT=IEND ENDIF ENDIF GOTO 10 C 30 LENG=OUTPT LINE(LENG+1)=0 RETURN ENTRY FLGINI RGS=.FALSE. RETURN END SUBROUTINE COORDS(LINE,LENG,POINT,X,Y,XREL,YREL,ERROR) BYTE LINE(*) INTEGER POINT,X,Y LOGICAL XREL,YREL,ERROR ERROR=.FALSE. I1=IPOS(LINE(POINT),LENG+1-POINT,1H[,1)+POINT-1 IF (I1.EQ.POINT-1) GOTO 100 I2=IPOS(LINE(I1),LENG+1-I1,1H],1)+I1-1 IF (I2.EQ.I1-1) GOTO 100 I3=IPOS(LINE(I1),I2+1-I1,1H,,1)+I1-1 C C Read x coord C IF (I2.EQ.I1+1 .OR. I3.EQ.I1+1) THEN XREL=.TRUE. X=0 ELSE IF (I3.EQ.I1-1) THEN DECODE(I2-I1-1,1000,LINE(I1+1),ERR=100) X 1000 FORMAT(I) ELSE DECODE(I3-I1-1,1000,LINE(I1+1),ERR=100) X ENDIF XREL=LINE(I1+1).EQ.'+' .OR. LINE(I1+1).EQ.'-' ENDIF C C Read y coord C IF (I2.EQ.I3+1 .OR. I3.EQ.I1-1) THEN YREL=.TRUE. Y=0 ELSE DECODE(I2-I3-1,1000,LINE(I3+1),ERR=100) Y YREL=LINE(I3+1).EQ.'+' .OR. LINE(I3+1).EQ.'-' ENDIF POINT=I2+1 RETURN 100 ERROR=.TRUE. RETURN END SUBROUTINE VALUE(LINE,LENG,POINT,NUM,ERROR) BYTE LINE(*) LOGICAL ERROR INTEGER POINT NUM=0 ICHARS=0 ERROR=.TRUE. 10 IF (POINT.GT.LENG) RETURN IF (LINE(POINT).LT.'0' .OR. LINE(POINT).GT.'9') RETURN ICHARS=ICHARS+1 C C Drop out with error after 6 digits C IF (ICHARS.EQ.6) THEN ERROR=.TRUE. RETURN ENDIF NUM=NUM*10+(LINE(POINT)-'0') ERROR=.FALSE. POINT=POINT+1 GOTO 10 END SUBROUTINE MGRAPH(LINE,LENG,OUTLNE,OUTLEN) BYTE LINE(*),OUTLNE(*),MGRAF,CQT VIRTUAL MGRAF(26,1000) INTEGER MPTR(26),OUTLEN LOGICAL QUOTED,MACDEF DATA MACDEF/.FALSE./ DATA MPTR/26*0/ QUOTED=.FALSE. OUTLEN=0 I=0 10 I=I+1 IF (I.GT.LENG) GOTO 20 IF ((LINE(I).EQ.1H' .OR. LINE(I).EQ.1H") .AND. .NOT.QUOTED) THEN CQT=LINE(I) QUOTED=.TRUE. ELSE IF (QUOTED .AND. LINE(I).EQ.CQT) THEN QUOTED=.FALSE. ENDIF IF (QUOTED .OR. LINE(I).NE.'@') THEN IF (MACDEF) THEN MPTR(MACRO)=MPTR(MACRO)+1 MGRAF(MACRO,MPTR(MACRO))=LINE(I) ELSE OUTLEN=OUTLEN+1 OUTLNE(OUTLEN)=LINE(I) ENDIF ELSE ! @ SYMBOL FOUND I=I+1 IF (I.GT.LENG) GOTO 20 IF (LINE(I).EQ.'.') THEN D TYPE 2000 D2000 FORMAT(' * CLEARING ALL MACROGRAPHS') DO 15 J=1,26 MPTR(J)=0 15 CONTINUE ELSE IF (LINE(I).EQ.';') THEN D TYPE 2010 D2010 FORMAT(' * ENDING MACROGRAPH') MACDEF=.FALSE. ELSE IF (LINE(I).EQ.':') THEN I=I+1 IF (I.GT.LENG) GOTO 20 MACRO=LINE(I)-'A'+1 IF (MACRO.LT.1 .OR. MACRO.GT.26) GOTO 20 D TYPE 2020,MACRO+'A'-1 D2020 FORMAT(' * DEFINING MACROGRAPH ',A1) MACDEF=.TRUE. MPTR(MACRO)=0 ELSE IF (LINE(I).GE.'A' .AND. LINE(I).LE.'Z') THEN MACRO=LINE(I)-'A'+1 D TYPE 2030,MACRO+'A'-1 D2030 FORMAT(' * CALLING MACROGRAPH ',A1) IF (MPTR(MACRO).NE.0) THEN DO 16 J=1,MPTR(MACRO) OUTLNE(OUTLEN+J)=MGRAF(MACRO,J) 16 CONTINUE OUTLEN=OUTLEN+MPTR(MACRO) ENDIF ENDIF ENDIF GOTO 10 20 RETURN END