C*********************************************************************** C Module: symgen.f (part of font generation tools in Xplot/sym) C C Copyright (C) 1996 Harold Youngren, Mark Drela C C This program is free software; you can redistribute it and/or modify C it under the terms of the GNU General Public License as published by C the Free Software Foundation; either version 2 of the License, or C (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a copy of the GNU General Public License C along with this program; if not, write to the Free Software C Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. C C Report problems to: guppy@maine.com C or drela@mit.edu C*********************************************************************** PROGRAM SYMGEN C------------------------------------------------------------------------ C C Interactive program for creating and modifying vector fonts. C C C A font set is kept stored in a database file XXXX.FNT, which C is read in when the program is invoked with C C % symgen XXXX C C The first line of XXXX.FNT is a list of the defined characters. C Each subsequent line then defines one character in the list: C C ABCD... C 21616 12168 13280 ... <- definition for "A" C 21616 12280 14880 ... <- definition for "B" C . C . C C Each 5-digit number defines a vector node x,y location on a 96x96 C grid, with 16,16 being the lower-left "origin" of the character. C See SUBR. SYMPLT header below for the encoding format. C If the numbers are zero or missing, then the font character C is not plotted (blank). C C Once the database has been edited, command "W" will generate C a Fortran INCLUDE file XXXX.INC, with the vector font information C placed in DATA statements. This is for use in a SYMBOL-type C routine to allow plotting of the font. Four sample databases, C include files, and routines already exist: C C CHAR.FNT CHAR.INC SUBR. PLCHAR (Upper,lower case letters) C SLAN.FNT SLAN.INC SUBR. PLSLAN (Slanted version of CHAR ) C MATH.FNT MATH.INC SUBR. PLMATH (Latex-like Greek symbols) C SYMB.FNT SYMB.INC SUBR. PLSYMB (Versatec plotting symbols) C C also available: SUBR. PLNUMB (Whole floating-point numbers) C C SUBR. PLCHAR, PLSLAN, and PLMATH (in ../plt_font.f) are identical C except for their INCLUDE statements. One can generate analogous C files and plot routines for any custom font, e.g. C C USER.FNT USER.INC SUBR. PLUSER C C C SUBR. PLSYMB is nearly the same, except that it takes an integer C argument ISYM = 0,1... to select the symbol defined on line ISYM+1: C C ABCD... C 21616 12168 13280 ... <- definition for ISYM = 0 C 21616 12280 14880 ... <- definition for ISYM = 1 C . C . C The ASCII characters on the first line are ignored in PLSYMB. C C PLSYMB also shifts the symbol down and left by 1/2 the symbol C size, so the symbol is centered on 0,0. This duplicates the C Versatec SYMBOL routine. Note that PLSYMB can only plot one C symbol at a time. C C C WARNING: The CHAR font implemented in PLCHAR is assumed to be C a "WYSIWIG" font, in which each font character closely C represents its ASCII index character. It is used by C other libPlt routines (and also this program!), and C hence should not be significantly modified. C C C------------------------------------------------------------------------ C COMMON /PLTC/ IDEV, IPSLU, SIZE, CH C CHARACTER*100 CHARS COMMON /CDATA/ CHARS COMMON /NDATA/ NCHAR, NODE(20,100) INTEGER NODET(20) C LOGICAL SAVED C CHARACTER*80 ARGP1, STRING, RANGE C CHARACTER*1 COPT, ANS, ALPH, ALPHO, ALPHT, KCHAR LOGICAL LABORT, LDONE C SIZE = 6.0 IDEV = 1 IPSLU = 0 C CH = 0.7 X0 = 0.0 Y0 = 0.0 C NCHARS = 0 C C---- get the XXXX working set name CALL GETARG(1,ARGP1) CALL LOAD(ARGP1) C C---- initial overlay character, plot-test string ALPHO = ' ' STRING = ' ' C C---- initial target character is first one in database ALPH = CHARS(1:1) SAVED = .TRUE. C CALL PLINITIALIZE CALL PLTALL(X0,Y0,ALPH,ALPHO,STRING) CALL PLFLUSH CALL PLEND C CALL GETCOLOR(ICOL0) C 1000 FORMAT(A) C 900 CONTINUE WRITE(*,1005) 1005 FORMAT(/' C hange target character' & /' I nput target character vectors' & /' M odify target character vectors' & /' T ranslate target character' & /' O verlay other character' & /' L ean character(s)' & /' P lot specified character string' & /' A dd a new character to database' & /' D elete a character from database' & /' S ave database' & /' W rite include file from current database' & /' Z oom' & /' U nzoom' & /' Q uit') C 910 WRITE(*,1015) ALPH 1015 FORMAT(/' Select option ( target character = ',A1,' ): ', $) READ(*,1000) COPT C IF(INDEX('Qq',COPT).NE.0) THEN IF(.NOT.SAVED) THEN WRITE(*,*) WRITE(*,*) 'Database not saved. Really quit ? N' READ(*,1000) ANS IF(INDEX('Yy',ANS) .EQ. 0) GO TO 900 ENDIF CALL PLCLOSE STOP ENDIF C NOPT = INDEX('CIMTOLPADSWZU',COPT) + INDEX('cimtolpadswzu',COPT) C GOTO (10,20,30,40,50,60,70,80,90,100,110,120,130) NOPT GOTO 900 C C=========================================== C---- select character 10 CONTINUE WRITE(*,1010) CHARS(1:NCHAR) 1010 FORMAT(/1X,A, & //1X,'Select new target character: ',$) READ(*,1000) ALPH C CALL PLTALL(X0,Y0,ALPH,ALPHO,STRING) CALL PLFLUSH CALL PLEND GO TO 900 C C=========================================== C---- input character 20 CONTINUE C KC = INDEX(CHARS,ALPH) IF(KC.EQ.0) THEN WRITE(*,*) 'Character is not in database.' GO TO 900 ENDIF C C---- clear node-input buffer array DO 201 K=1, 20 NODET(K) = 0 201 CONTINUE C C C---- small node-select symbol size CHS = 0.010*CH C CALL PLTALL(X0,Y0,ALPH,ALPHO,STRING) CALL PABORT CALL PDONE C ccc CALL PLCHAR(X0,Y0,CH,ALPH,0.0,1) C CALL PLFLUSH C WRITE(*,*) WRITE(*,*) 'Input stroke points (double-click to end a stroke)...' C ILAST = -999 JLAST = -999 ISTAT = 2 C DO 205 K=1, 20 204 CALL GETCURSORXY(XC,YC,KCHAR) C C------ exit if clicked inside "ABORT" box IF(LABORT(XC,YC)) THEN WRITE(*,*) 'Database unchanged.' GO TO 209 ENDIF C C------ finish up if clicked inside "DONE" box IF(LDONE(XC,YC)) GO TO 206 C C------ set integer coordinates and clip to within field I = INT(64.0*(XC-X0)/CH + 16.5) J = INT(64.0*(YC-Y0)/CH + 16.5) I = MAX( 0 , MIN(I,96) ) J = MAX( 0 , MIN(J,96) ) C IF(ILAST.EQ.I .AND. JLAST.EQ.J) THEN ISTAT = 2 ILAST = -999 JLAST = -999 WRITE(*,*) 'Will start new stroke...' GO TO 204 ENDIF C WRITE(*,1026) K, I, J 1026 FORMAT(1X,' node',I3,': ', 2I5) C C------ set new node location in buffer array NODET(K) = 10000*ISTAT + 100*I + J C C------ put small symbol over actual node location XNODE = CH*FLOAT(I-16)/64.0 YNODE = CH*FLOAT(J-16)/64.0 IF(ILAST.EQ.-999 .OR. JLAST.EQ.-999) THEN CALL PLOT(XNODE,YNODE,3) ELSE CALL PLOT(XNODE,YNODE,2) ENDIF CALL NEWCOLORNAME('orange') CALL PLSYMB(XNODE,YNODE,CHS,1,0.0,0) CALL NEWCOLOR(ICOL0) CALL PLFLUSH C C------ set up for next input point ILAST = I JLAST = J ISTAT = 1 C 205 CONTINUE WRITE(*,*) '20-node array limit reached' 206 CONTINUE C C---- put buffer array into database KC = INDEX(CHARS,ALPH) DO 207 K=1, 20 NODE(K,KC) = NODET(K) 207 CONTINUE WRITE(*,*) WRITE(*,*) 'Database updated.' SAVED = .FALSE. C C---- replot whole character 209 CALL PLEND CALL PLTALL(X0,Y0,ALPH,ALPHO,STRING) CALL PLFLUSH C CALL PLEND GO TO 900 C C=========================================== C---- modify character 30 CONTINUE WRITE(*,1030) ALPH 1030 FORMAT(/1X, 'Modifying character: ', A) C KC = INDEX(CHARS,ALPH) IF(KC.EQ.0) THEN WRITE(*,*) 'Character is not in database.' GO TO 900 ENDIF C C---- save database node array for restoration after abort DO 301 K=1, 20 NODET(K) = NODE(K,KC) 301 CONTINUE C CALL PLTINI CALL PLTALL(X0,Y0,ALPH,ALPHO,STRING) C ccc CALL PLSYMB(X0,Y0,CH,ALPH,0.0,1) c C C---- small node-select symbol size CHS = 0.010*CH C CALL PABORT CALL PDONE CALL PLFLUSH C WRITE(*,*) WRITE(*,*) 'Click on old/new point pairs...' DO 305 IPASS=1, 12345 C CALL GETCURSORXY(XC,YC,KCHAR) C C------ restore and exit if clicked inside "ABORT" box IF(LABORT(XC,YC)) THEN DO 3052 K=1, 20 NODE(K,KC) = NODET(K) 3052 CONTINUE WRITE(*,*) 'Database unchanged.' GO TO 309 ENDIF C C------ finish up if clicked inside "DONE" box IF(LDONE(XC,YC)) GO TO 306 C C------ set integer coordinates and clip to within field I = INT(64.0*(XC-X0)/CH + 16.5) J = INT(64.0*(YC-Y0)/CH + 16.5) I = MAX( 0 , MIN(I,96) ) J = MAX( 0 , MIN(J,96) ) C C------ find nearest vector node IDMIN = 1000000 KMIN = 0 DO 3054 K=1, 20 ISTAT = NODE(K,KC) / 10000 IF(ISTAT.EQ.0) GO TO 3055 C NODEB = NODE(K,KC) - ISTAT*10000 IT = NODEB / 100 JT = NODEB - 100*IT C IDIST = (I - IT)**2 + (J - JT)**2 IF(IDIST.LT.IDMIN) THEN IDMIN = IDIST KMIN = K ENDIF 3054 CONTINUE 3055 CONTINUE C KT = KMIN IF(KT.EQ.0) THEN WRITE(*,*) 'Nearest point not found.' GO TO 900 ENDIF C C------ plot small symbol on nearest vector node to identify it ISTAT = NODE(KT,KC) / 10000 NODEB = NODE(KT,KC) - ISTAT*10000 IT = NODEB / 100 JT = NODEB - 100*IT C CALL NEWCOLORNAME('red') XNODE = CH*FLOAT(IT-16)/64.0 YNODE = CH*FLOAT(JT-16)/64.0 CALL PLSYMB(XNODE,YNODE,CHS,1,0.0,0) FK = FLOAT(KT) CALL PLNUMB(XNODE+1.5*CHS,YNODE+1.5*CHS,3.0*CHS,FK,0.0,-1) CALL NEWCOLOR(ICOL0) C C------ now get new location for vector node KT CALL GETCURSORXY(XC,YC,KCHAR) C IF(LABORT(XC,YC)) THEN DO 3056 K=1, 20 NODE(K,KC) = NODET(K) 3056 CONTINUE WRITE(*,*) 'No changes made.' GO TO 309 ENDIF C IF(LDONE(XC,YC)) GO TO 306 C C------ integer coordinates for new location I = INT(64.0*(XC-X0)/CH + 16.5) J = INT(64.0*(YC-Y0)/CH + 16.5) I = MAX( 0 , MIN(I,96) ) J = MAX( 0 , MIN(J,96) ) C C------ encode coordinates into database NODE(KT,KC) = 10000*ISTAT + 100*I + J C C------ replot everything CALL PLEND CALL PLTALL(X0,Y0,ALPH,ALPHO,STRING) CALL PABORT CALL PDONE CALL PLFLUSH C 305 CONTINUE 306 CONTINUE C WRITE(*,*) WRITE(*,*) 'Database updated.' SAVED = .FALSE. C C---- replot final state 309 CALL PLEND CALL PLTALL(X0,Y0,ALPH,ALPHO,STRING) CALL PLFLUSH C CALL PLEND GO TO 900 C C=========================================== C---- translate current character 40 CONTINUE C DO K=1, 20 NODET(K) = 0 ENDDO C 41 WRITE(*,1040) 1040 FORMAT(/' Enter dX, dY (in points): ', $) READ(*,*,ERR=41) ID, JD C IC = INDEX(CHARS,ALPH) DO 42 K=1, 20 C C------ unpack node coordinates from database ISTAT = NODE(K,IC) / 10000 IF(ISTAT.EQ.0) GO TO 43 C NODEB = NODE(K,IC) - ISTAT*10000 I = NODEB / 100 J = NODEB - 100*I C C------ shift coordinates I = I + ID J = J + JD C IF(I.LT.0 .OR. I.GT.96) THEN WRITE(*,*) 'X movement puts character outside field 0..96' GO TO 40 ENDIF C IF(J.LT.0 .OR. J.GT.96) THEN WRITE(*,*) 'Y movement puts character outside field 0..96' GO TO 40 ENDIF C C------ encode new coordinates in buffer array NODET(K) = 10000*ISTAT + 100*I + J C 42 CONTINUE 43 CONTINUE C C---- store shifted nodes in database from buffer array DO 46 K=1, 20 NODE(K,IC) = NODET(K) 46 CONTINUE C CALL PLTALL(X0,Y0,ALPH,ALPHO,STRING) CALL PLFLUSH CALL PLEND GO TO 900 C C=========================================== C---- select overlay character 50 CONTINUE ALPHO = ' ' WRITE(*,1050) CHARS(1:NCHAR) 1050 FORMAT(/1X,A, & //1X,'Select character to overlay ( if none: ',$) READ(*,1000) ALPHO C CALL PLTALL(X0,Y0,ALPH,ALPHO,STRING) CALL PLFLUSH CALL PLEND GO TO 900 C C=========================================== C---- lean character(s) 60 CONTINUE WRITE(*,1060) 1060 FORMAT(/' Enter character range to lean (e.g. AZ): ',$) READ(*,1000) RANGE IF(INDEX(RANGE,' ').EQ.1) GO TO 900 C 62 WRITE(*,1062) 1062 FORMAT(/1X,'Enter tan(lean_angle), + to right: ',$) READ (*,*,ERR=62) TANA C CALL LEAN(RANGE,TANA) C CALL PLTALL(X0,Y0,ALPH,ALPHO,STRING) CALL PLFLUSH CALL PLEND GO TO 900 C C=========================================== C---- enter plot test string 70 CONTINUE WRITE(*,1070) 1070 FORMAT(/' Enter string: ',$) READ(*,1000) STRING C CALL PLTALL(X0,Y0,ALPH,ALPHO,STRING) CALL PLFLUSH CALL PLEND GO TO 900 C C=========================================== C---- add character to database 80 CONTINUE IF(NCHAR+1.GE.100) THEN WRITE(*,*) WRITE(*,*) 'Array limit reached. Cannot add character.' GO TO 900 ENDIF C WRITE(*,1080) 1080 FORMAT(/1X,'Enter character to be added: ',$) READ(*,1000) ALPH IC = INDEX(CHARS,ALPH) IF(IC.NE.0) THEN WRITE(*,*) 'That is already in database.' GO TO 900 ENDIF C 81 WRITE(*,1081) CHARS(1:NCHAR), ALPH 1081 FORMAT(/1X,A, & //1X,' ... insert ',A1, & ' before which character ? ( to append) : ',$) READ(*,1000) ALPHT IC = INDEX(CHARS,ALPHT) IF(IC.EQ.0) IC = NCHAR+1 C C---- move up all characters above IC to make room for new character IF(IC.LE.NCHAR) THEN CHARS(IC+1:NCHAR+1) = CHARS(IC:NCHAR) DO 802 KC=NCHAR, IC, -1 DO 8024 K=1, 20 NODE(K,KC+1) = NODE(K,KC) 8024 CONTINUE 802 CONTINUE ENDIF C NCHAR = NCHAR+1 C C---- set new character and clear its vectors CHARS(IC:IC) = ALPH DO 804 K=1, 20 NODE(K,IC) = 0 804 CONTINUE C CALL PLTALL(X0,Y0,ALPH,ALPHO,STRING) CALL PLFLUSH CALL PLEND GO TO 900 C C=========================================== C---- delete character from database 90 CONTINUE C WRITE(*,1090) 1090 FORMAT(/1X,'Select character to be deleted: ',$) READ(*,1000) ALPH C IF(INDEX(' ',ALPH).EQ.1) THEN WRITE(*,*) 'No action taken' GO TO 900 ENDIF C IC = INDEX(CHARS,ALPH) C IF(IC.EQ.0) THEN WRITE(*,*) 'Character not in database.' GO TO 900 ENDIF C C---- pull down all characters above the one to be deleted CHARS(IC:NCHAR) = CHARS(IC+1:NCHAR+1) DO 902 KC=IC, NCHAR-1 DO 9024 K=1, 20 NODE(K,KC) = NODE(K,KC+1) 9024 CONTINUE 902 CONTINUE NCHAR = NCHAR-1 IC = MIN(IC,NCHAR) C C---- set new current character ALPH = CHARS(IC:IC) C CALL PLTALL(X0,Y0,ALPH,ALPHO,STRING) CALL PLFLUSH CALL PLEND GO TO 900 C C=========================================== C---- write out database 100 CONTINUE CALL SAVE(ARGP1,SAVED) GO TO 900 C C=========================================== C---- write out include file 110 CONTINUE CALL WRIT(ARGP1) GO TO 910 C C=========================================== C---- set zoom 120 CONTINUE CALL USETZOOM(.FALSE.,.TRUE.) CALL REPLOT(1) GO TO 910 C C=========================================== C---- clear zoom 130 CONTINUE CALL CLRZOOM CALL REPLOT(1) GO TO 910 C END SUBROUTINE LOAD(ARGP1) CHARACTER*80 ARGP1,FNAME C CHARACTER*100 CHARS COMMON /CDATA/ CHARS COMMON /NDATA/ NCHAR, NODE(20,100) C 1000 FORMAT(A) C K = INDEX(ARGP1,' ') - 1 IF(K.LT.1) THEN WRITE(*,*) 'SYMGEN argument error: ', ARGP1 STOP ENDIF C FNAME = ARGP1(1:K) // '.FNT' C OPEN(3,FILE=FNAME,STATUS='OLD',ERR=90) READ(3,1000) CHARS NCHAR = INDEX(CHARS,' ') - 1 C DO IC=1, NCHAR DO K=1, 20 NODE(K,IC) = 0 ENDDO ENDDO C DO IC=1, NCHAR READ(3,*,END=80) (NODE(K,IC),K=1,20) C C------ clear any invalid points (should be zero anyway) DO K=1, 20 ISTAT = NODE(K,IC) / 10000 IF(ISTAT.EQ.0) NODE(K,IC) = 0 ENDDO ENDDO C 80 CONTINUE CLOSE(3) C WRITE(*,1200) CHARS(1:NCHAR) 1200 FORMAT(/1X,'Database read for the following character set...' & //1X, A) C RETURN C 90 CONTINUE WRITE(*,*) 'Database file not found: ',FNAME(1:60) RETURN C END SUBROUTINE SAVE(ARGP1,SAVED) CHARACTER*80 ARGP1,FNAME CHARACTER*1 ANS CHARACTER*4 CNUM LOGICAL SAVED C CHARACTER*100 CHARS COMMON /CDATA/ CHARS COMMON /NDATA/ NCHAR, NODE(20,100) C C 1000 FORMAT(A) 1500 FORMAT(1X,20I6) 2100 FORMAT(/' File ',A,' exits. Overwrite ? Y') C C KARG = INDEX(ARGP1,' ') - 1 C C---- write new database file for next SYMGEN call FNAME = ARGP1(1:KARG) // '.FNT' OPEN(3,FILE=FNAME,STATUS='OLD',ERR=10) C WRITE(*,2100) FNAME(1:KARG+4) READ(*,1000) ANS IF(INDEX('Nn',ANS) .NE. 0) THEN CLOSE(3) RETURN ENDIF C 10 OPEN(3,FILE=FNAME,STATUS='UNKNOWN') C WRITE(3,1000) CHARS(1:NCHAR) DO IC=1, NCHAR WRITE(3,1500) (NODE(K,IC),K=1,20) ENDDO CLOSE(3) WRITE(*,*) WRITE(*,*) 'New database file written: ', FNAME(1:KARG+4) SAVED = .TRUE. C RETURN END SUBROUTINE WRIT(ARGP1) CHARACTER*80 ARGP1,FNAME,LINE CHARACTER*1 ANS CHARACTER*4 CNUM C CHARACTER*100 CHARS COMMON /CDATA/ CHARS COMMON /NDATA/ NCHAR, NODE(20,100) C C---- write new include file for SYMBOL-type routine C 1000 FORMAT(A) 1500 FORMAT(1X,20I6) 2100 FORMAT(/' File ',A,' exits. Overwrite ? Y') C KARG = INDEX(ARGP1,' ') - 1 C FNAME = ARGP1(1:KARG) // '.INC' OPEN(4,FILE=FNAME,STATUS='OLD',ERR=20) C WRITE(*,2100) FNAME(1:KARG+4) READ(*,1000) ANS IF(INDEX('Nn',ANS) .NE. 0) THEN CLOSE(4) GO TO 28 ENDIF C 20 OPEN(4,FILE=FNAME,STATUS='UNKNOWN') WRITE(4,*) ' ' WRITE(4,3010) NCHAR, NCHAR C WRITE(4,*) ' ' NARR = (NCHAR-1)/10 DO N=0, NARR NDIM = MIN( 10 , NCHAR-N*10) WRITE(4,3201) N, NDIM ENDDO DO N=0, NARR WRITE(4,3202) 10*N+1, N ENDDO C C---Write character translation data statements WRITE(4,3020) NCHAR DO L=1, 8 K1 = 26*L - 25 K2 = 26*L IF(K1 .GT. NCHAR) GO TO 21 K2 = MIN(K2,NCHAR) WRITE(4,3021) K1,K2, CHARS(K1:K2) ENDDO 21 CONTINUE C C---Write out character node data DO N=0, NARR IC1 = 10*N + 1 IC2 = 10*N + 10 IC2 = MIN(IC2,NCHAR) C IC = IC1 WRITE(4,3210) N DO IC=IC1, IC2-1 WRITE(4,3220) (NODE(K,IC),K= 1,10) WRITE(4,3220) (NODE(K,IC),K=11,20) ENDDO IC = IC2 WRITE(4,3220) (NODE(K,IC),K= 1,10) WRITE(4,3230) (NODE(K,IC),K=11,20) ENDDO C CLOSE(4) C 3010 FORMAT(' CHARACTER*',I3,' CHARS' & /' INTEGER NODE(20,',I3,')') C 3201 FORMAT(' DIMENSION NODE',I1,'(20,',I2,')') 3202 FORMAT(' EQUIVALENCE ( NODE(1,',I3,') , NODE',I1,'(1,1) )') C 3020 FORMAT(' DATA NCHARS / ',I3,' /') 3021 FORMAT(' DATA CHARS(',I3,':',I3,') / ''',A,''' /') C 3210 FORMAT( ' DATA NODE',I1,' /') 3220 FORMAT( ' & ',10(I5,',') ) 3230 FORMAT( ' & ', 9(I5,','),I5,' /' ) C CLOSE(4) WRITE(*,*) WRITE(*,*) 'New include file written: ', FNAME(1:KARG+4) WRITE(*,*) 'Put include file in Xplot directory,', & ' make libPlt.a to implement new font.' C 28 CONTINUE RETURN C END SUBROUTINE LEAN(RANGE,TANA) CHARACTER*(*) RANGE C CHARACTER*1 ALPH C CHARACTER*100 CHARS COMMON /CDATA/ CHARS COMMON /NDATA/ NCHAR, NODE(20,100) C KC1 = INDEX(CHARS,RANGE(1:1)) KC2 = INDEX(CHARS,RANGE(2:2)) C IF(KC1.EQ.0 .OR. KC2.EQ.0) THEN WRITE(*,*) 'Specified range not in current character set.' WRITE(*,*) 'No action taken.' RETURN ENDIF C C---- go over each character... DO 12 KC=KC1, KC2 C C------ go over each node DO K=1, 20 C C-------- strip off leading point-status digit ISTAT = NODE(K,KC) / 10000 NODEB = NODE(K,KC) - ISTAT*10000 C IF(ISTAT.GT.0) THEN C C---------- decode x and y location coordinates I = NODEB / 100 J = NODEB - 100*I C C---------- perform tilt I = I + INT( FLOAT(J-16)*TANA ) C C---------- encode coordinates back into database NODE(K,KC) = 10000*ISTAT + 100*I + J C ENDIF C ENDDO C 12 CONTINUE C RETURN END SUBROUTINE PLTINI COMMON /PLTC/ IDEV, IPSLU, SIZE, CH C RELWSIZ = 0.8 CALL PLOPEN(RELWSIZ,IPSLU,IDEV) CALL PLOTABS(0.125,0.125,-3) CALL NEWFACTOR(SIZE) CALL PLOT(0.25*CH,0.25*CH,-3) C RETURN END ! PLTINI SUBROUTINE PLTALL(X0,Y0,ALPH,ALPHO,STRING) COMMON /PLTC/ IDEV, IPSLU, SIZE, CH CHARACTER*1 ALPH, ALPHO CHARACTER*80 STRING C CHSEQ = 0.10*CH CHSTR = 0.05*CH C XSEQ = CH + CH/4.0 + 0.03*CH YSEQ = CH + CH/4.0 - 1.10*CHSEQ C XCHR = CH + CH/4.0 + 0.03*CH YCHR = CH - 0.07*CH C XSTR = XCHR YSTR = YCHR - 0.65*CH C CALL PLTINI CALL PLTGRD(X0,Y0,CH) CALL SYMPLT(X0,Y0,CH,ALPH,0.0,-1) CALL SYMPLT(X0,Y0,CH,ALPHO,0.0,1) CALL SYMPLT(XSTR,YSTR,CHSTR,STRING,0.0,80) CALL PLTCHR(XCHR,YCHR) C XQ = XSEQ CHQ = CHSEQ c CALL PLOT(XQ,YSEQ,3) DO ISCAL=0, 10 CALL SYMPLT(XQ,YSEQ,CHQ,ALPH,0.0,1) c CALL PLCHAR(999.,999.,CHQ,ALPH,0.0,1) XQ = XQ + CHQ CHQ = CHQ * 0.75 ENDDO C RETURN END SUBROUTINE PLTCHR(XCHR,YCHR) COMMON /PLTC/ IDEV, IPSLU, SIZE, CH C CHARACTER*1 ALPH C CHARACTER*100 CHARS COMMON /CDATA/ CHARS COMMON /NDATA/ NCHAR, NODE(20,100) C CHP = 0.040*CH C DO 10 ILIN=1, 5 YPLT = YCHR - CHP - 2.5*CHP*(ILIN-1) DO 102 KC=1, 26 XPLT = XCHR + 0.5*CHP + 1.0*CHP*(KC-1) XPLT = XCHR + 1.0*CHP*(KC-1) C IC = KC + 26*(ILIN-1) IF(IC.GT.NCHAR) GO TO 15 C ALPH = CHARS(IC:IC) CALL SYMPLT(XPLT,YPLT,CHP,ALPH,0.0,1) 102 CONTINUE 10 CONTINUE C 15 CONTINUE RETURN END SUBROUTINE SYMPLT(XC,YC,CH,STRING,ANGLE,NC1) C---------------------------------------------------------------- C Plots character string using vector font database NODE(..) C C Each NODE(..) value has the form sxxyy C C xx = location of polyline point 0 ... 96 C yy C s = 2 if point is the start of a new polyline stroke C = 1 if point is inside or at the end of stroke C = 0 if point is not valid C---------------------------------------------------------------- CHARACTER*(*) STRING C CHARACTER*1 ALPH C CHARACTER*100 CHARS COMMON /CDATA/ CHARS COMMON /NDATA/ NCHAR, NODE(20,100) C NC = ABS(NC1) CHS = 0.010*CH C CALL GETCOLOR(ICOL0) C C---- go over each character... DO 12 IC=1, NC C C------ set plot location X0 = XC + CH*FLOAT(IC-1) Y0 = YC C ALPH = STRING(IC:IC) KC = INDEX(CHARS,ALPH) C IF(KC.NE.0) THEN C C-------- decode and plot each node DO K=1, 20 C C---------- strip off leading point-status digit ISTAT = NODE(K,KC) / 10000 NODEB = NODE(K,KC) - ISTAT*10000 C C---------- decode x and y location coordinates I = NODEB / 100 J = NODEB - 100*I C X = X0 + CH*FLOAT(I-16)/64.0 Y = Y0 + CH*FLOAT(J-16)/64.0 C IF (ISTAT.EQ.0) THEN GOTO 12 ELSEIF (ISTAT.EQ.1) THEN CALL PLOT(X,Y,2) ELSE CALL PLOT(X,Y,3) ENDIF C C---------- plot symbol at vector nodes IF(NC1.LT.0) THEN CALL NEWCOLORNAME('blue') CALL PLSYMB(X,Y,CHS,1,0.0,0) FK = FLOAT(K) CALL PLNUMB(X+1.5*CHS,Y+1.5*CHS,3.0*CHS,FK,0.0,-1) CALL NEWCOLOR(ICOL0) CALL PLOT(X,Y,3) ENDIF C ENDDO ENDIF C 12 CONTINUE C RETURN END SUBROUTINE PLTGRD(X0,Y0,CH) DATA LMASK1, LMASK2, LMASK3 / -32640, -30584, -21846 / C CALL NEWPEN(1) C NX = 24 NY = 24 DX = CH/16.0 DY = CH/16.0 CALL PLGRID(X0-0.25*CH,Y0-0.25*CH, NX,DX, NY,DY, LMASK2 ) C NX = 2 NY = 2 DX = CH/2.0 DY = CH/2.0 CALL PLGRID(X0,Y0, NX,DX, NY,DY, LMASK3 ) C DO I=0,2 DO J=0,2 XPLT = X0 + DX*FLOAT(I) YPLT = Y0 + DY*FLOAT(J) CALL PLSYMB(XPLT,YPLT,CH/96.0,5,0.0,0) ENDDO ENDDO C CALL PLFLUSH C RETURN END SUBROUTINE PDONE COMMON /PLTC/ IDEV, IPSLU, SIZE, CH COMMON /DONE/ XDONE(2), YDONE(2) C C---- set DONE window XDONE(1) = CH + CH/4.0 + 0.125/SIZE XDONE(2) = CH + CH/4.0 + 1.025/SIZE YDONE(1) = - CH/4.0 + 0.525/SIZE YDONE(2) = - CH/4.0 + 1.425/SIZE C C---- plot DONE window CALL GETCOLOR(ICOL0) CALL NEWCOLORNAME('green') CALL PLOT(XDONE(1),YDONE(1),3) CALL PLOT(XDONE(2),YDONE(1),2) CALL PLOT(XDONE(2),YDONE(2),2) CALL PLOT(XDONE(1),YDONE(2),2) CALL PLOT(XDONE(1),YDONE(1),2) C CHA = MIN( (XDONE(2)-XDONE(1))/8.0 , (YDONE(2)-YDONE(1))/1.5 ) XCA = 0.5*(XDONE(2)+XDONE(1)) - 2.0*CHA YCA = 0.5*(YDONE(2)+YDONE(1)) - 0.5*CHA CALL PLCHAR(XCA,YCA,CHA,'DONE',0.0,4) CALL NEWCOLOR(ICOL0) C RETURN END FUNCTION LDONE(XC,YC) COMMON /DONE/ XDONE(2), YDONE(2) LOGICAL LDONE C C---- return T if location XC,YC falls within DONE window C LDONE = XC .GE. XDONE(1) .AND. & XC .LE. XDONE(2) .AND. & YC .GE. YDONE(1) .AND. & YC .LE. YDONE(2) C RETURN END SUBROUTINE PABORT COMMON /PLTC/ IDEV, IPSLU, SIZE, CH COMMON /ABRT/ XABORT(2), YABORT(2) C C---- set abort window XABORT(1) = CH + CH/4.0 + 0.125/SIZE XABORT(2) = CH + CH/4.0 + 1.025/SIZE YABORT(1) = - CH/4.0 YABORT(2) = - CH/4.0 + 0.400/SIZE C C---- plot abort window CALL GETCOLOR(ICOL0) CALL NEWCOLORNAME('red') CALL PLOT(XABORT(1),YABORT(1),3) CALL PLOT(XABORT(2),YABORT(1),2) CALL PLOT(XABORT(2),YABORT(2),2) CALL PLOT(XABORT(1),YABORT(2),2) CALL PLOT(XABORT(1),YABORT(1),2) C CHA = MIN( (XABORT(2)-XABORT(1))/8.0 , (YABORT(2)-YABORT(1))/1.5 ) XCA = 0.5*(XABORT(2)+XABORT(1)) - 2.5*CHA YCA = 0.5*(YABORT(2)+YABORT(1)) - 0.5*CHA CALL PLCHAR(XCA,YCA,CHA,'ABORT',0.0,5) CALL NEWCOLOR(ICOL0) C RETURN END FUNCTION LABORT(XC,YC) COMMON /ABRT/ XABORT(2), YABORT(2) LOGICAL LABORT C C---- return T if location XC,YC falls within abort window C LABORT = XC .GE. XABORT(1) .AND. & XC .LE. XABORT(2) .AND. & YC .GE. YABORT(1) .AND. & YC .LE. YABORT(2) C RETURN END