C ========================================================================= C PROGRAM TYPSET C 13-Aug-80 I.M.Calhaem C ========================================================================= C C ------ PROGRAM TO CONVERT ASCII AND TYPSETTING CHARACTERS ----- C TO INVERTED TTS CODE C C PROGRAMMED W.D.SMITH, FROM ORIGINAL VERSION BY I.M.CALHAEM. C (modifications by I.M.Calhaem) C C change: V2.1 convert '-' before a numeral into printing minus C V2.2 upper & lower commands acceptable C V2.2 ABORT stop if illegal square brackets C V2.3 ^ and _ characters included in 'INVAL' C (apparently omitted by mistake) C V2.4 code added to automatically put a word space at the C end of a line if the last character is not a command. C V3.0 add subroutine DISPLY(X,Y,N) which displays on the C VT100 screen the various fonts and typesetting C codes. It also checks formats. C V3.1 minor change to output format error line in DISPLY C V3.2 DISPLY recognises [st] as begining a format C V3.3 minor change to remove hyphen at end of line C V3.4 error corrected in automatic word space logic C (V3.3 not not always insert space when needed) C and font error modified (minor display only) C V3.5 Minor change to output font error line in DISPLY C and to output blank lines to screen C V3.6 File assignment now checks for .TTS file C V3.7 Asks for any more input files. Output a single file. C V3.8 System disk may be removed, prompts for no of blocks. C V3.9 Displays current file name C V4.0 Clears top line before displaying name C V4.1 Allow code of form >ZFL< and >zfl< C Fix to detect Bell O and also output 16 nulls at start C V4.2 Add call purge before replacing system disk. C RT-11 V4 closes tempory files with call exit and this C >>>>>> overwrites the system disk directory!!!!! C C INPUT IS FROM AN ASCII FILE PREPARED USING 'KED' C OUTPUT IS TO A DISK FILE, READY TO BE TRANSFERRED TO AN C 800 BPI NRZ MAGNETIC TAPE FOR THE PRINTER, OR SENT C DIRECTLY TO THE LINOTRON BY COPYING TO DEVICE 'TS:' C C SPECIAL CHARACTERS USED IN THE INPUT FILE ARE :- C ~ SHIFT C # BELL C " BETA C \ SUPERSHIFT C ^ TAU C _ EN RULE C = ONLY USED FOR BELL BELL C IF AN EQUALS SIGN IS REQUIRED C IT MUST BE INSERTED WITH A PI CHARACTER. C [ ] SQUARE BRACKETS ARE USED TO GENERATE C SPECIAL CODES. C { } CURLY BRACKETS ARE USED TO GENERATE C PI GRID CHARACTERS AND TO INPUT STANDARD C BELL CODES. C Typset V4.2 C C SUBROUTINE BUF(X,N) BUFFERS 512 CHARACTERS AND OUTPUTS TO DISK FILE C C SUBROUTINE DISPLY(X,Y,N) C CONVERTS LINOTRON STYLE CODES TO SCREEN ATTRIBUTES C SUBROUTINE NAME(X) C DISPLAYS CURRENT FILE NAME AT TOP RIGHT OF SCREEN C C IF A {o} (BELL O) IS ENCOUNTERED THE BUFFER C IS EMPTIED C C ============================================================================ C * * * COMPILE WITH /R:400. * * * C ============================================================================ C C C The following changes are required if C the terminal is not VT100 compatable. C C ===================== C C C C Put C in first column of the statements labeled VT100 C C Replace the subroutine - DISPLY(X,Y,NCHAR) C with - SCOPY(X,Y) C C Remove the subroutines - CLEAR C NAME C C C====================================================================== C Typset V4.2 COMMON IU,NBLOCK,SY0 COMMON /DISPLY/NF LOGICAL*1 X(132),Y(400),INVAL(128),BROUT1(25),BROUT2(9) 1,ASYM(2),SHI(10),SHO(10),SSHI(3),SSHO(3),SHIFT,CH LOGICAL*1 FIN(15),FOUT(15),ANS(3),ERR,SY0 INTEGER SYM,SSYM,BRIN1(25),BRIN2(9) INTEGER FSPEC(4) EQUIVALENCE (ASYM,SYM) DATA NBLOCK/480/ DATA FSPEC/3RDK ,3RTEM,3RP ,3RDAT/ DATA SSYM/'|!'/,SHIFT/.FALSE./ DATA INVAL/"000,"177,"177,"177,"177,"177,"177,"007,"177,"177, 1 "177,"177,"177,"015,"016,"177,"177,"177,"177,"177, 2 "177,"177,"177,"177,"177,"177,"177,"177,"177,"177, 3 "177,"177,"040,"041,"042,"043,"044,"045,"046,"047, 4 "050,"051,"052,"053,"054,"055,"056,"057,"060,"061, 5 "062,"063,"064,"065,"066,"067,"070,"071,"072,"073, 6 "074,"075,"076,"077,"100,"101,"102,"103,"104,"105, 7 "106,"107,"110,"111,"112,"113,"114,"115,"116,"117, 8 "120,"121,"122,"123,"124,"125,"126,"127,"130,"131, 9 "132,"133,"134,"135,"136,"137,"140,"141,"142,"143, 1 "144,"145,"146,"147,"150,"151,"152,"153,"154,"155, 2 "156,"157,"160,"161,"162,"163,"164,"165,"166,"167, 3 "170,"171,"172,"173,"174,"177,"016,"177/ DATA BRIN1 /'ae','oe','/o', 1 'th','en','em','cr','ql','qc','qr','ss','pa','st', 2 'er', 3 'TH','EN','EM','CR','QL','QC','QR','SS','PA','ST', 4 'ER'/ DATA BROUT1/"020,"021,"022, 1 "023,"024,"025,"015,"026,"027,"030,"134,"031,"032, 2 "033, 3 "023,"024,"025,"015,"026,"027,"030,"134,"031,"032, 4 "033/ DATA BRIN2 /'AE','OE','/O','|?','<<','>>','N-','M-','D.'/ DATA BROUT2/"020,"021,"022,"063,"065,"064,"055,"070,"066/ DATA SHI/'`','&',':','?','(','!','/','%','"','_'/ DATA SHO/1H','9',';','0',')','1','2','7','^','8'/ DATA SSHI/'*','$','@'/ DATA SSHO/'1',';','9'/ NF=1 ! font for DISPLY SY0=.FALSE. C WRITE(7,98)"33,'[','2','J', ! VT100 1 "33,'[','2',';','2','4','r' 98 FORMAT(X,11A1) ! clear & split screen C--------------------------------------------------------------------- C VERSION NUMBER C -------------- WRITE (7,99) 99 FORMAT(X,' V4.2') C--------------------------------------------------------------------- C Typset V4.2 C C----- OPEN INPUT FILE C 1 WRITE(7,2) 2 FORMAT(' Enter name of input file : '$) CALL GETSTR(5,FIN,14,ERR) IF(ERR.LT.0)GO TO 1 OPEN(UNIT=1,NAME=FIN,TYPE='OLD',READONLY,BUFFERCOUNT=2,ERR=1) READ (1,101,ERR=1) 101 FORMAT(X) REWIND 1 CALL NAME(FIN) C C----- OPEN OUTPUT FILE C 3 WRITE (7,4) 4 FORMAT('+Enter name of output file: '$) CALL GETSTR(5,FOUT,14,ERR) IF(ERR.LT.0)GO TO 3 NO=LEN(FOUT) IF(NO.EQ.0)GO TO 6 CALL INDEX(FOUT,'SY',1,M) IF(M.NE.0)SY0=.TRUE. CALL INDEX(FOUT,'PD0',1,M) IF(M.NE.0)SY0=.TRUE. CALL INDEX(FOUT,'DX0',1,M) IF(M.NE.0)SY0=.TRUE. CALL INDEX(FOUT,'DY0',1,M) IF(M.NE.0)SY0=.TRUE. CALL INDEX(FOUT,'.',1,M) IF(M.EQ.0)GO TO 3 CALL INSERT('.TTS',FOUT,M) C C-- INHIBIT CONTROL C'S IF USING SYSTEM DISK C IF(SY0)CALL SCCA(IFLAG) IF(SY0)PAUSE ' Now replace system disk with blank disk 1 - then press RETURN' GO TO 8 C C-- FIND OUT HOW MANY FREE BLOCKS ARE AVAILABLE C 6 CALL SCOPY('NL:',FOUT) GO TO 9 8 CALL INDEX(FOUT,':',1,M) IF(M.EQ.0)GO TO 14 !use default disk CALL IRAD50(M-1,FOUT,FSPEC(1)) !use specified disk 14 ICHAN=IGETC() IF(ICHAN.GE.0)GO TO 15 WRITE(7,1003)"7,"7,"7 1003 FORMAT(/,3A1,' FATAL OUTPUT ERROR - CHECK DISK') CLOSE(UNIT=2) ! V4.2 IF(SY0) PAUSE ' Replace system disk and press return' CALL CLEAR CALL EXIT 15 IAVAIL=IENTER(ICHAN,FSPEC,-1) CALL PURGE(ICHAN) CALL IFREEC(ICHAN) IF(IAVAIL.GT.0)GO TO 17 C Typset V4.2 C-- WRITE(7,1005)"7,"7,"7 1005 FORMAT(/,3A1,' NO BLOCKS ARE AVAILABLE ON THE OUTPUT DISK') 16 CLOSE(UNIT=2) ! V4.2 IF(SY0) PAUSE ' Replace system disk and press return' CALL CLEAR CALL EXIT C C-- CHECK NUMBER OF BLOCKS SATISFACTORY C 17 WRITE (7,103)IAVAIL 103 FORMAT(X,I4,' blocks are available - continue ? ',$) READ (5,104,ERR=17) ANS 104 FORMAT(3A1) IF(ANS(1).NE.'Y') GO TO 16 NBLOCK=IAVAIL C-- 9 OPEN(UNIT=2,NAME=FOUT,TYPE='NEW',ACCESS='DIRECT', 1 RECORDSIZE=128,ASSOCIATEVARIABLE=IU,INITIALSIZE=-1, 2 MAXREC=NBLOCK,BUFFERCOUNT=1) WRITE (2'1,ERR=3) IU=1 C C----- INITIALISE OUTPUT BUFFERS C CALL BUF(Y,0) C Typset V4.2 C C----- READ A STRING FROM INPUT FILE C 5 READ (1,105,END=10) X 105 FORMAT(132A1) C C----- TRUNCATE TRAILING BLANKS C NCHAR=132 7 IF (X(NCHAR).NE."040) GO TO 20 NCHAR=NCHAR-1 GO TO 7 C C----- END OF FILE ENCOUNTERED - ASK FOR ANOTHER FILE C 10 CONTINUE WRITE (7,1000)"33,'[','m' ! RESETS VT100 SCREEN WRITE (7,106)"7,"7,"7 106 FORMAT(/,3A1,' ANY MORE INPUT FILES? '$) READ(5,107,ERR=10)ANS 107 FORMAT(7A1) IF((ANS(1).NE.'Y').AND.(ANS(1).NE.'N')) GO TO 10 IF(ANS(1).EQ.'N') CALL BUF(Y,-1) CLOSE(UNIT=1) 11 WRITE (7,2) CALL GETSTR(5,FIN,14,ERR) IF(ERR.EQ.-1)GO TO 11 NI=LEN(FIN) C C----- TERMINATE IF NO FILE GIVEN C IF(NI.EQ.0) CALL BUF(Y,-1) CALL ASSIGN(1,FIN,NI,'RDO') READ (1,101,ERR=11) REWIND 1 CALL NAME(FIN) GO TO 5 C C----- REPLACE INVALID CODES C 20 IF (NCHAR.GT.0) GO TO 25 WRITE (7,26) GO TO 5 C C----- DISPLAY TEXT ON SCREEN C 25 CALL DISPLY(X,Y,NCHAR) NY=LEN(Y) WRITE (7,26) (Y(I),I=1,NY) 26 FORMAT(X,255A1) DO 30 I=1,NCHAR L=X(I)+1 30 X(I)=INVAL(L) C C----- WORK ALONG THE STRING CONVERTING SPECIAL CHARACTER SEQUENCES C IA=0 IB=0 40 IA=IA+1 50 IF (IA.GT.NCHAR) GO TO 900 CH=X(IA) C Typset V4.2 C C----- SKIP INVALID CODES AND MULTIPLE BLANKS C IF (CH.EQ."177) GO TO 40 IF (CH.NE."040) GO TO 110 IF (IB.LE.0) GO TO 500 IF (Y(IB)-"040) 500,40,500 C C----- CHECK FOR SQUARE BRACKETS C 110 IF (CH.NE."133) GO TO 200 IF (X(IA+3).NE."135) GO TO 160 ASYM(1)=X(IA+1) ASYM(2)=X(IA+2) DO 130 L=1,25 130 IF (SYM.EQ.BRIN1(L)) GO TO 135 DO 140 L=1,9 140 IF (SYM.EQ.BRIN2(L)) GO TO 145 IF (SYM.NE.SSYM) GO TO 160 IB=IB+2 Y(IB-1)="134 Y(IB)="020 GO TO 150 135 IB=IB+1 Y(IB)=BROUT1(L) GO TO 150 145 IA=IA+3 CH=BROUT2(L) GO TO 230 150 IA=IA+3 GO TO 520 160 WRITE (7,1001) X(IA),X(IA+1),X(IA+2),X(IA+3) 1001 FORMAT(/' UNRECOGNIZABLE SYMBOL ',4A1/) WRITE (7,1000)"33,'[','m' ! RESETS VT100 SCREEN 1000 FORMAT(X,3A1) WRITE (7,1002)"7,"7,"7 1002 FORMAT(/,3A1,' CODE CONVERSION ABORTED') CLOSE(UNIT=2) ! V4.2 IF(SY0) PAUSE ' Replace System disk and press return' CALL CLEAR CALL EXIT C C----- CONVERT UPPER CASE TO SHIFT-LOWER CASE-UNSHIFT C 200 IF (CH.GE."101.AND.CH.LE."132) GO TO 225 IF (CH.GE."133.AND.CH.LE."135) GO TO 300 IF (CH.EQ."136) GO TO 500 DO 210 L=1,10 210 IF (CH.EQ.SHI(L)) GO TO 220 GO TO 300 220 CH=SHO(L) GO TO 230 225 CH=CH+"040 230 IF (IB.LE.0) GO TO 235 IF (Y(IB).EQ."017) GO TO 242 IF (Y(IB).EQ."016) GO TO 240 C Typset V4.2 235 IB=IB+3 Y(IB-2)="016 GO TO 245 240 IB=IB+1 SHIFT=.FALSE. 242 IB=IB+1 245 Y(IB-1)=CH Y(IB)="017 GO TO 40 C C----- CONVERT SUPERSHIFT CHARACTERS C 300 DO 305 L=1,3 305 IF (CH.EQ.SSHI(L)) GO TO 310 GO TO 350 310 IB=IB+2 Y(IB-1)="134 Y(IB)=SSHO(L) GO TO 520 C C----- SPECIAL SYMBOL + C 350 IF (CH.NE."053) GO TO 375 IB=IB+5 Y(IB-4)="043 Y(IB-3)="056 Y(IB-2)="063 Y(IB-1)="062 Y(IB)="071 GO TO 520 C C----- SPECIAL SYMBOL - (MINUS BEFORE A NUMERAL) C 375 IF (CH.NE."055) GO TO 400 IF ((X(IA+1).LT."060).OR.(X(IA+1).GT."071)) GO TO 400 IB=IB+5 Y(IB-4)="043 Y(IB-3)="056 Y(IB-2)="063 Y(IB-1)="063 Y(IB)="060 GO TO 520 C C----- BELL CODES C 400 IF (CH.NE."173.AND.CH.NE."007) GO TO 500 IB=IB+1 Y(IB)="043 IA=IA+1 IF (X(IA).NE."117) GO TO 410 CH="157 GO TO 500 410 IF (X(IA).NE."075.AND.X(IA).NE."007) GO TO 50 IB=IB+1 Y(IB)="043 GO TO 40 C C----- COPY OTHERWISE UNRECOGNIZED CHARACTERS C 500 IB=IB+1 Y(IB)=CH C Typset V4.2 C C----- CASE OF 'SHIFT' FORCED IN C IF (CH.NE."016) GO TO 520 SHIFT=.TRUE. IF (IB.LE.1) GO TO 40 IF (Y(IB-1).NE."016) GO TO 510 IB=IB-1 GO TO 40 510 IF (Y(IB-1).EQ."017) IB=IB-2 GO TO 40 520 IF (.NOT.SHIFT) GO TO 40 IB=IB+1 Y(IB)="017 SHIFT=.FALSE. GO TO 40 C C----- CONVERT TO TTS CODE AND OUTPUT VIA SUBROUTINE BUF C (WORD SPACE ADDED IF REQUIRED) C 900 IF (IB.LE.0) GO TO 5 IF (Y(IB).GE."141) GO TO 905 IF (Y(IB).LE."015) GO TO 910 IF((Y(IB).GE."023).AND.(Y(IB).LE."043)) GO TO 910 IF((Y(IB).GE."074).AND.(Y(IB).LE."136)) GO TO 910 IF (Y(IB).NE."055) GO TO 905 ! V3.5 IB=IB-1 GO TO 910 905 IB=IB+1 Y(IB)="40 910 CALL BUF(Y,IB) GO TO 5 END C Typset V4.2 C====================================================================== SUBROUTINE BUF(X,N) C====================================================================== C C Purpose: to output characters to binary file. C Initialize with N=0, C Flush to finish with N negative. C C ASSOCIATED VARIABLE FOR FILE HELD IN BLANK COMMON. C C====================================================================== C COMMON IU,NBLOCK,SY0 LOGICAL*1 X(N),XBUF(512),TTS(128),SY0 DATA TTS/"000,"000,"000,"000,"000,"000,"000,"072,"000,"000, 1 "000,"000,"000,"002,"033,"037,"051,"045,"070,"040, 2 "056,"064,"066,"057,"076,"073,"044,"077,"000,"000, 3 "000,"000,"004,"000,"000,"072,"000,"000,"000,"042, 4 "000,"061,"000,"000,"046,"062,"047,"000,"055,"067, 5 "071,"060,"052,"041,"065,"074,"054,"043,"000,"053, 6 "050,"000,"010,"000,"000,"000,"000,"000,"000,"000, 7 "000,"000,"000,"000,"000,"000,"000,"000,"000,"000, 8 "000,"000,"000,"000,"000,"000,"000,"000,"000,"000, 9 "000,"000,"063,"000,"075,"000,"000,"030,"023,"016, 1 "022,"020,"026,"013,"005,"014,"032,"036,"011,"007, 2 "006,"003,"015,"035,"012,"024,"001,"034,"017,"031, 3 "027,"025,"021,"000,"000,"000,"000,"000/ IF (N) 200,50,100 50 NC=0 DO 51 I=1,16 51 XBUF(I)="000 NC=16 RETURN C C----- CHECK FOR BELL O C 100 IF (X(1).NE."043) GO TO 110 !not bell code IF (X(2).EQ."157) GO TO 150 !bell o IF((X(2).EQ."016).AND.(X(3).EQ."157)) GO TO 150 !bell shift o C C----- NORMAL OUTPUT WITHOUT BELL O C 110 DO 120 I=1,N NC=NC+1 L=X(I)+1 XBUF(NC)=TTS(L) IF (NC.LT.512) GO TO 120 IF(IU.GT.NBLOCK)GO TO 1100 WRITE (2'IU) XBUF NC=0 120 CONTINUE RETURN C Typset V4.2 C C----- OUTPUT BELL O AND NULL BYTES C 150 DO 160 J=1,2 NC=NC+1 L=X(J)+1 XBUF(NC)=TTS(L) IF (NC.LT.512) GO TO 160 IF(IU.GT.NBLOCK)GO TO 1100 WRITE (2'IU) XBUF NC=0 160 CONTINUE IF (NC.LE.0) GO TO 170 DO 165 J=NC+1,512 165 XBUF(J)="000 IF(IU.GT.NBLOCK)GO TO 1100 WRITE (2'IU) XBUF NC=0 170 RETURN C C----- CLEAR BUFFER TO FINISH C 200 IF (NC.LE.0) GO TO 230 DO 220 I=NC+1,512 220 XBUF(I)="000 IF(IU.GT.NBLOCK)GO TO 1100 WRITE (2'IU) XBUF 230 WRITE (7,1000)"33,'[','m' ! RESETS VT100 SCREEN 1000 FORMAT(X,3A1) WRITE (7,1004)"7,"7,"7 1004 FORMAT(/,3A1,' CHARACTER CONVERSION COMPLETE') GO TO 1200 1100 WRITE(7,1101)"7,"7,"7 1101 FORMAT(/,3A1,' OUTPUT FILE FULL') 1200 CLOSE(UNIT=2) IF(SY0) PAUSE ' Replace System disk and press return' CALL CLEAR CALL EXIT END C Typset V4.2 C================================================================= SUBROUTINE DISPLY(X,Y,NC) C================================================================= C C Purpose: to convert linotron codes into character changes C on the VT100 screen. C Also checks for matching > and < C C ----------- C X is the input string C Y is the output string C N is the number of characters in X C------------------------------------------------------------------ C COMMON IU,NBLOCK,SY0 COMMON /DISPLY/ NF BYTE CODE(8,5),NUM(2),FRMT,ERR,SY0 BYTE X(132),Y(400) DATA FRMT/.FALSE./ DATA CODE/ 1 "33,'[','0',';','0',';','0','m', ! '0' normal 2 "33,'[','0',';','0',';','4','m', ! '4' underline 3 "33,'[','0',';','0',';','1','m', ! '1' bold 4 "33,'[','0',';','1',';','4','m', ! '4' bold underline 5 "33,'[','0',';','0',';','7','m'/ ! '7' reverse (codes) C DO 6 I=1,400 6 Y(I)="000 IY=0 N=NC C C CHECK FOR >, {, or [ DO 100 I=1,N IF((X(I).NE.'>').AND.(X(I).NE.'{').AND.(X(I).NE.'['))GOTO 10 IF(X(I).EQ.'>')FRMT=.TRUE. DO 5 J=1,8 ! turn on reverse 5 Y(IY+I+J-1)=CODE(J,5) ! turn off font IY=IY+8 GO TO 90 C C CHECK FOR <, }, or ] C 10 IF((X(I).NE.'<').AND.(X(I).NE.'}').AND.(X(I).NE.']'))GOTO 20 IF((X(I-2).EQ.'S').AND.(X(I-1).EQ.'T'))FRMT=.TRUE. IF((X(I-2).EQ.'S').AND.(X(I-1).EQ.'T'))GOTO 90 IF((X(I-2).EQ.'s').AND.(X(I-1).EQ.'t'))FRMT=.TRUE. IF((X(I-2).EQ.'s').AND.(X(I-1).EQ.'t'))GOTO 90 C IF(X(I).EQ.'<')FRMT=.FALSE. Y(IY+I)=X(I) IF(I.EQ.N)GO TO 14 IF((X(I+1).EQ.'<') .OR. (X(I+1).EQ.'}') .OR. 1 (X(I+1).EQ.']')) GOTO 100 C 14 DO 15 J=1,8 ! turn off reverse 15 Y(IY+I+J)=CODE(J,NF) ! turn on font IY=IY+8 GO TO 100 C Typset V4.2 C C CHECK FOR CHANGE IN FONT C 20 IF(.NOT.FRMT)GO TO 90 IF((X(I).NE.'F').AND.(X(I).NE.'f'))GO TO 90 IF((X(I-1).EQ.'Z').AND.(X(I+1).EQ.'L'))GO TO 90 ! allow >ZFL< IF((X(I-1).EQ.'z').AND.(X(I+1).EQ.'l'))GO TO 90 ! allow >zfl< NUM(1)="040 NUM(2)="040 IF((X(I+1).GE."60).AND.(X(I+1).LE."071))GO TO 23 GO TO 300 23 NUM(2)=X(I+1) IF((X(I+2).LT."60).OR.(X(I+2).GT."071)) GO TO 24 NUM(1)=NUM(2) NUM(2)=X(I+2) C C FIND TYPE FONT (ROMAN, ITALIC, BOLD, OR BOLD ITALIC) C 24 DECODE(2,25,NUM,ERR=300)L 25 FORMAT(I2) NF=MOD(L,4) ! NF is remainder of L/4 IF(NF.EQ.0)NF=4 C C -------- END OF MAIN LOOP --------- C 90 Y(IY+I)=X(I) 100 CONTINUE C C CHECK FOR MATCHING END FORMAT (<) C IF(.NOT.FRMT)GO TO 200 WRITE (7,106) (Y(J),J=1,IY+N) 106 FORMAT(X,255A1) WRITE (7,106)"33,'[','m' ! RESETS VT100 SCREEN WRITE (7,1002)"7,"7,"7 1002 FORMAT(/,3A1,' MISSING END FORMAT ..... <') CLOSE(UNIT=2) ! V4.2 IF(SY0) PAUSE ' Replace System disk and press return' CALL CLEAR CALL EXIT 200 RETURN C 300 WRITE (7,106) (Y(J),J=1,IY+I-1),X(I),X(I+1),X(I+2) WRITE (7,106)"33,'[','m' ! RESETS VT100 SCREEN WRITE (7,1004)"7,"7,"7 1004 FORMAT(/,3A1,' INCORRECT FONT CODE') CLOSE(UNIT=2) ! V4.2 IF(SY0) PAUSE ' Replace System disk and press return' CALL CLEAR CALL EXIT END C Typset V4.2 C============================================================================= SUBROUTINE NAME(X) C============================================================================= C C Purpose: to display the current file name in the top right hand C corner of the VT100 screen in reverse video. C C----------------------------------------------------------------------------- C LOGICAL*1 X(15),CODE(7,4) DATA CODE/ 1 "33,'[','1',';','5','5','f', ! direct address 2 "33,'[','0',';','0','0','K', ! erase line 3 "33,'[','0',';','0','7','m', ! reverse video 4 "33,'[','0',';','0','0','m'/ ! normal C WRITE(7,5)"33,'7' ! save cursor 5 FORMAT('+',2A1) DO 1 I=1,3 1 WRITE(7,10)(CODE(J,I),J=1,7) 10 FORMAT('+',7A1,$) WRITE(7,20)X 20 FORMAT('+This file - ',15A1) WRITE(7,10)(CODE(J,4),J=1,7) WRITE(7,5)"33,'8' ! restore cursor RETURN END C============================================================================ SUBROUTINE CLEAR C============================================================================ C C Purpose: to clear VT100 screen and remove split scrolling C C---------------------------------------------------------------------------- C WRITE(7,10)"33,'7' WRITE(7,10)"33,'[','1',';','2','4','r' WRITE(7,10)"33,'8' 10 FORMAT('+',7A1) RETURN END