PROGRAM COMPSE C EXTERNAL CELL, CONVRT C BYTE ESC DATA ESC /27/ C BYTE SI DATA SI /15/ C BYTE SO DATA SO /14/ C CHARACTER ASP DATA ASP /''''/ C INTEGER CHRNO, OPTION, COLUMN, ROW, ERRNO, FCS1, FCS2 C INTEGER GRID(8) DATA GRID /8*0/ C DATA IOATT /"1420/ C CHARACTER FILNAM*27 DATA FILNAM /'DL3:[005,002]FILENAME.TXT'/ C CHARACTER CHRGRD(4)*18 C C DISABLE THE FILE NOT FOUND MESSAGE C CALL ERRSET(29,.TRUE.,.FALSE.,.TRUE.,.FALSE.) C C ATTACH THE TERMINAL - RECOGNIZE ESCAPE SEQUENCES C CALL WTQIO(IOATT,5,1) C C GET THE NAME OF THE FILE TO SAVE THE CHARACTER SET IN C 50 WRITE(UNIT=5,FMT=100) 100 FORMAT(///,' ',10X,'Enter a file name for the character set: ',$) C READ (UNIT=5,FMT='(A27)') FILNAM C K = INDEX(FILNAM,'.') IF (K .EQ. 0) STOP 'YOU MUST GIVE THE FILE NAME AN EXTENSION' C C OPEN THE FILE C CALL ERRSNS C OPEN (UNIT=1,NAME=FILNAM,STATUS='OLD',ACCESS='DIRECT', * RECL=4,ERR=200) C GOTO 400 C 200 CALL ERRSNS(ERRNO,FCS1,FCS2,1) C IF (ERRNO .NE. 29) STOP 'Fatal Open Error' C OPEN (UNIT=1,NAME=FILNAM,STATUS='NEW',ACCESS='DIRECT', * RECL=4) C DO 300 CHRNO=1,94 300 WRITE(UNIT=1,REC=CHRNO) (GRID(I), I=1,8) C C 400 WRITE(UNIT=5,FMT='(1H+,A1,3H[2J)') ESC C 450 WRITE(UNIT=5,FMT=500) 500 FORMAT(' ',20X,'COMPOSE CHARACTER MENU',///, * 12X,'1 - Create a Selected Character',/, * 12X,'2 - Create a Complete Character Set File',/, * 12X,'3 - Create Another Character Set',/, * 12X,'4 - Exit this Program',///, * 16X,'Please select one of the above options: ',$) C READ(UNIT=5,FMT='(I1)') OPTION C GOTO (700,900,1050,1100), OPTION C WRITE(UNIT=5,FMT='(1H+,A1,3H[2J)') ESC C WRITE(UNIT=5,FMT=600) 600 FORMAT(' ERROR - Invalid OPTION selected - try again',///) C GOTO 450 C C 700 WRITE(UNIT=5,FMT=800) 800 FORMAT('0',10X,'Enter the column, row of the character that') C WRITE(UNIT=5,FMT=850) 850 FORMAT(' ',10X,'you want to create (range: 2,1 to 7,14): ',$) C READ(UNIT=5,FMT='(2I2)') COLUMN, ROW C CHRNO = 16 * (COLUMN - 2) + ROW C IF (CHRNO .LT. 1 .OR. CHRNO .GT. 94) THEN C WRITE(UNIT=5,FMT=865) 865 FORMAT(1H0,3X,'ERROR - The column and/or the row number is * out of range - please re-enter the values.',//) GOTO 700 C ENDIF C C C READ IN THE CURRENT VALUE OF THE BINARY CHARACTER GRID C READ(UNIT=1,REC=CHRNO) (GRID(I), I=1,8) C WRITE(UNIT=5,FMT=875) ESC, COLUMN, ROW 875 FORMAT('+',A1,'[2J',15X,'CURRENTLY COMPOSING CHARACTER NO. ',I1, * '/',I2.2,//) C C CALL THE CELL MACRO SUBROUTINE C CALL CELL(GRID) C C SAVE THE CHARACTER GRID IN THE CHARACTER SET FILE C WRITE(UNIT=1,REC=CHRNO) (GRID(I), I=1,8) C GOTO 400 C C 900 FILNAM(K+1:K+3) = 'TXT' C OPEN (UNIT=2,NAME=FILNAM,STATUS='NEW',FORM='FORMATTED', * CARRIAGECONTROL='LIST') C WRITE(UNIT=2,FMT='(A1,8HP1;1;1{1)') ESC C K = 1 DO 1000 CHRNO=1,94 C READ(UNIT=1,REC=CHRNO) (GRID(I), I=1,8) CALL CONVRT(GRID,CHRGRD(K)) IF (IMOD(CHRNO,4) .NE. 0) GOTO 1000 WRITE(UNIT=2,FMT='(4A18)') (CHRGRD(K), K = 1,4) K = 0 C 1000 K = K + 1 C CHRGRD(2) (18:18) = ' ' WRITE(UNIT=2,FMT='(2A18)') (CHRGRD(K), K=1,2) C WRITE(UNIT=2,FMT='(A1,1H\)') ESC WRITE(UNIT=2,FMT='(A1,2H)B)') ESC WRITE(UNIT=2,FMT='(A1,2H)1)') ESC WRITE(UNIT=2,FMT='(A1,3H[2J)') ESC WRITE(UNIT=2,FMT='(A1,2H[H)') ESC C WRITE(UNIT=2,FMT='(A1)') SO C WRITE(UNIT=2,FMT='(7H !"#$%&,A1,24H()*+,-./0123456789:;<=>?)') ASP WRITE(UNIT=2,FMT='(32H@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_)') WRITE(UNIT=2,FMT='(31H`abcdefghijklmnopqrstuvwxyz{|}~)') C WRITE(UNIT=2,FMT='(1H )') WRITE(UNIT=2,FMT='(1H )') C WRITE(UNIT=2,FMT='(A1,9H#3 !"#$%&,A1,24H()*+,-./0123456789:; *<=>?)') ESC, ASP WRITE(UNIT=2,FMT='(A1,9H#4 !"#$%&,A1,24H()*+,-./0123456789:; *<=>?)') ESC, ASP C WRITE(UNIT=2,FMT='(A1,34H#3@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_)') ESC WRITE(UNIT=2,FMT='(A1,34H#4@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_)') ESC C WRITE(UNIT=2,FMT='(A1,33H#3`abcdefghijklmnopqrstuvwxyz{|}~)') ESC WRITE(UNIT=2,FMT='(A1,33H#4`abcdefghijklmnopqrstuvwxyz{|}~)') ESC C WRITE(UNIT=2,FMT='(A1)') SI C CLOSE (UNIT=2) C GOTO 400 C C 1050 CLOSE(UNIT=1) C GOTO 50 C C 1100 CALL EXIT C END