aboutsummaryrefslogtreecommitdiff
path: root/plotlib/sym/symgen.f
diff options
context:
space:
mode:
Diffstat (limited to 'plotlib/sym/symgen.f')
-rw-r--r--plotlib/sym/symgen.f1179
1 files changed, 1179 insertions, 0 deletions
diff --git a/plotlib/sym/symgen.f b/plotlib/sym/symgen.f
new file mode 100644
index 0000000..4b8f054
--- /dev/null
+++ b/plotlib/sym/symgen.f
@@ -0,0 +1,1179 @@
+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 (<return> 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 ? (<return> 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
+
+