sources-request@panda.UUCP (03/12/86)
Mod.sources: Volume 4, Issue 25
Submitted by: seismo!s3sun!sdcsvax!brian (Brian Kantor)
The following is a fortran-77 subroutine called 'symbol' which will use the
Public-Domain Hershey fonts to draw letters, numbers, and symbols. It is
in use here at UCSD in connection with several plotting packages for lettering
and for point plotting.
Part 2 of this distribution contains the BLOCKDATA statements which
form the actual fonts themselves, and a description of the format in
which they are stored.
I contacted the authors of this subroutine and obtained their permission to
distribute the subroutine. I'm in the process of writing a 'c' subroutine
to also use the Hershey data. I will submit that for posting when I'm
done.
Brian Kantor UCSD Computer Graphics Lab
c/o B-028, La Jolla, CA 92093 (619) 452-6865
decvax\ brian@sdcsvax.ucsd.edu
ihnp4 >--- sdcsvax --- brian
ucbvax/ Kantor@Nosc
-------------------------------------------------------------------------------
SUBROUTINE HERSHEY(X,Y,HEIGHT,ITEXT,THETA,NTEXT)
C
C FEATURES:
C 1) FOUR HERSHEY LETTER FONTS--SIMPLEX,COMPLEX,ITALIC, AND DUPLEX--
C ARE PROVIDED IN UPPER AND LOWER CASE ROMAN
C 2) TWO HERSHEY LETTER FONTS--SIMPLEX AND COMPLEX--ARE PROVIDED IN
C UPPER AND LOWER CASE GREEK
C 3) 47 SPECIAL MATHEMATICAL SYMBOLS, E.G. INTEGRAL SIGN,DEL, ARE
C PROVIDED
C 4) SUPER- AND SUB-SCRIPTING IS POSSIBLE WITHIN A CHARACTER STRING
C WITHOUT SEPARATE CALLS TO SYMBOL
C
C CHANGE OF FONT IS MADE BY ENCLOSING THE NAME OF THE FONT IN UPPER
C CASE IN BACKSLASHES, E.G \SIMPLEX\. THREE LETTERS SUFFICE TO
C SPECIFY THE FONT. SIMPLEX IS THE DEFAULT FONT ON THE INITIAL CALL
C TO SYMBOL. A FONT REMAINS IN EFFECT UNTIL EXPLICITLY CHANGED.
C SUPER- OR SUB-SCRIPTING IS ACCOMPLISHED BY ENCLOSING THE EXPRESSION
C TO BE SUPER- OR SUB-SCRIPTED IN CURLY BRACKETS AND PRECEDING IT BY
C SUP OR SUB. THE CLOSING CURLY BRACKET TERMINATES THE
C SUPER- OR SUB-SCRIPTING AND RETURNS TO NORMAL CHARACTER PLOTTING.
C NOTE THAT SUPER- AND SUB-SCRIPT LETTERS ARE PLOTTED WITH A
C DIFFERENT CHARACTER SIZE.
C GREEK LETTERS ARE DRAWN BY ENCLOSING THE ENGLISH NAME OF THE
C LETTER IN BACKSLASHES, E.G. \ALPHA\. THE CASE OF THE FIRST LETTER
C DETERMINES THE CASE OF THE GREEK LETTER. THE CLOSING BACKSLASH MUST
C BE INCLUDED.
C ANY SYMBOL MAY BE CALLED BY ENCLOSING THE SYMBOL NUMBER+1000 IN
C BACKSLASHES. THIS IS THE ONLY WAY TO CALL SOME SYMBOLS, ESPECIALLY
C SPECIAL MATHEMATICAL SYMBOLS.
C THE SYMBOL NUMBERS ARE
C 1-26 UPPER CASE ROMAN SIMPLEX
C 27-52 LOWER CASE ROMAN SIMPLEX
C 53-72 SIMPLEX NUMBERS AND SYMBOLS
C 73-96 UPPER CASE GREEK SIMPLEX
C 97-120 LOWER CASE GREEK SIMPLEX
C 121-146 UPPER CASE ROMAN COMPLEX
C 147-172 LOWER CASE ROMAN COMPLEX
C 173-192 COMPLEX NUMBERS AND SYMBOLS
C 193-216 UPPER CASE GREEK COMPLEX
C 217-240 LOWER CASE GREEK COMPLEX
C 241-266 UPPER CASE ROMAN ITALIC
C 267-292 LOWER CASE ROMAN ITALIC
C 293-312 ITALIC NUMBERS AND SYMBOLS
C 313-338 UPPER CASE ROMAN DUPLEX
C 339-364 LOWER CASE ROMAN DUPLEX
C 365-384 DUPLEX NUMBERS AND SYMBOLS
C 385-432 SPECIAL MATHEMATICAL SYMBOLS
C ADDITIONAL FEATURES ADDED FEB 1982
C THE PEN MAY BE MOVED BACK TO THE START POINT FOR THE PREVIOUS
C CHARACTER BY \BS\. THIS IS USEFUL, FOR EXAMPLE, IN WRITING
C INTEGRAL SIGNS WITH LIMITS ABOVE AND BELOW THEM.
C
C SYMBOL PARAMETERS TAKEN FROM N.M.WOLCOTT, FORTRAN IV ENHANCED
C CHARACTER GRAPHICS, NBS
C
C A.CHAVE IGPP/UCSD AUG 1981, MODIFIED FEB 1982 BY A. CHAVE,
C R.L. PARKER, AND L. SHURE
C
C X,Y ARE THE COORDINATES IN INCHES FROM THE CURRENT ORIGIN TO THE
C LOWER LEFT CORNER OF THE 1ST CHARACTER TO BE PLOTTED. IF EITHER
C IS SET TO 999.0 THEN SAVED NEXT CHARACTER POSITION IS USED.
C HEIGHT IS THE CHARACTER HEIGHT IN INCHES
C ITEXT IS AN INTEGER ARRAY CONTAINING THE TEXT TO BE PLOTTED
C THETA IS THE POSITIVE CCW ANGLE W.R.T. THE X-AXIS
C NTEXT IS THE NUMBER OF CHARACTERS IN ITEXT TO PLOT
C IF NTEXT.LT.-1 THE PEN IS DOWN TO (X,Y) AND A SINGLE SPECIAL
C CENTERED SYMBOL IS PLOTTED. IF NTEXT.EQ.-1 THE PEN IS UP TO
C (X,Y) AND A SINGLE SPECIAL CENTERED SYMBOL IS PLOTTED. IF
C NTEXT=0 A SINGLE SIMPLEX ROMAN CHARACTER FROM ITEXT, LEFT-
C JUSTIFIED, IS PLOTTED. IF NTEXT.GT.0 NTEXT CHARACTERS FROM
C ITEXT ARE DECODED AND NCHR CHARACTERS ARE PLOTTED WHERE
C NCHR.LE.NTEXT TO REMOVE BACKSLASHES, COMMAND CODES, ETC.
C
C PROGRAMMED IN FORTRAN-77
C
CHARACTER TEXT*350
INTEGER ITEXT(1)
INTEGER ISTART(432),ISSTAR(22),SYMBCD(4711),SSYMBC(128)
REAL WIDTH(432),SUPSUB(2),RAISE(20)
COMMON /OFFSET/ IOFF,JUST1,JUST2
COMMON /AJUST/ NCHR,ICHR(350)
COMMON /IALPH/ SYMBCD,ISTART,SSYMBC,ISSTAR
COMMON /IWID/ WIDTH
PARAMETER (PI=3.1415926,RAD=PI/180.)
SAVE XO,YO
DATA FACTOR/0.75/,SUPSUB/0.50,-0.50/, IUP,IDOWN/3,2/
C ICHR(J) CONTAINS THE SYMBOL NUMBER OF THE JTH SYMBOL OR A
C CODE TO INDICATE SPACE (1000),BEGIN SUPER-SCRIPTING (1001),
C BEGIN SUB-SCRIPTING (1002), OR END SUPER/SUB-SCRIPTING (1003),
C OR BACK-SPACE (1004).
C ISTART(ICHR(J)) CONTAINS THE ADDRESS IN SYMBOL OF THE JTH
C CHARACTER. SYMBCD CONTAINS THE PEN INSTRUCTIONS STORED IN A
C SPECIAL FORMAT. ISSTAR AND SSYMBC CONTAIN ADDRESSES AND PEN
C INSTRUCTIONS FOR THE SPECIAL CENTERED SYMBOLS. WIDTH CONTAINS
C THE WIDTHS OF THE CHARACTERS.
C
C IXTRCT GETS NBITS FROM IWORD STARTING AT THE NSTART BIT FROM THE
C RIGHT
IXTRCT(NSTART,NBITS,IWORD)=MOD(IWORD/(2**(NSTART-NBITS)),
$ 2**NBITS)+((1-ISIGN(1,IWORD))/2)*
$ (2**NBITS-MIN0(1,MOD(-IWORD,
$ 2**(NSTART-NBITS))))
C
YOFF=0.0
SI=SIN(RAD*THETA)
CO=COS(RAD*THETA)
SCALE=HEIGHT/21.
IF(SCALE.EQ.0.0)RETURN
IF(X.GE.999.0)THEN
XI=XO
ELSE
XI=X
ENDIF
IF(Y.GE.999.0)THEN
YI=YO
ELSE
YI=Y
ENDIF
IF(NTEXT.LT.0)THEN
C PLOT A SINGLE SPECIAL CENTERED SYMBOL
IF(NTEXT.LT.-1)CALL HSTYLUS(XI,YI,IDOWN)
IA=ITEXT(1)+1
IS=ISSTAR(IA)
IB=30
20 IPEN=IXTRCT(IB,3,SSYMBC(IS))
IF(IPEN.EQ.0)THEN
CALL HSTYLUS(XI,YI,IUP)
XI=XI+20.0*CO
YI=YI+20.0*SI
XO=XI
YO=YI
RETURN
ENDIF
IX=IXTRCT(IB-3,6,SSYMBC(IS))
IY=IXTRCT(IB-9,6,SSYMBC(IS))
XX=SCALE*(IX-32)
YY=SCALE*(IY-32)
CALL HSTYLUS(XI+XX*CO-YY*SI,YI+XX*SI+YY*CO,IPEN)
IB=45-IB
IF(IB.EQ.30)IS=IS+1
GOTO 20
ELSEIF (NTEXT.EQ.0)THEN
C PLOT A SINGLE SIMPLEX ROMAN CHARACTER
ISAV=IOFF
IOFF=0
WRITE(TEXT(1:1),25)ITEXT(1)
25 FORMAT(A1)
CALL CHRCOD(TEXT,1)
IOFF=ISAV
IS=ISTART(ICHR(1))
IB=30
40 IPEN=IXTRCT(IB,3,SYMBCD(IS))
IF(IPEN.EQ.0)THEN
XI=XI+CO*SCALE*WIDTH(ICHR(1))
YI=YI+SI*SCALE*WIDTH(ICHR(1))
XO=XI
YO=YI
RETURN
ENDIF
IX=IXTRCT(IB-3,6,SYMBCD(IS))
IY=IXTRCT(IB-9,6,SYMBCD(IS))
XX=(IX-10)*SCALE
YY=(IY-11)*SCALE
CALL HSTYLUS(XI+CO*XX-SI*YY,YI+CO*YY+SI*XX,IPEN)
IB=45-IB
IF(IB.EQ.30)IS=IS+1
GOTO 40
ELSE
C PLOT A CHARACTER STRING.
C FIRST FIND POINTER ARRAY ICHR CONTAINING THE STARTS OF CHARACTERS-
C BUT ONLY IF JUST1 AND JUST2 ARE NOT 1, WHEN ICHR IS ASSUMED
C CORRECTLY TRANSMITTED THROUGH COMMON /AJUST/.
IF(JUST1.NE.1.OR.JUST2.NE.1)THEN
N=NTEXT
K=1
DO 50 I=1,N
WRITE(TEXT(I:I),55)ITEXT(I)
50 K=K+1
55 FORMAT(A1)
CALL CHRCOD(TEXT,N)
ENDIF
JUST2=2
OLDWID=0.0
L=1
RSCALE=SCALE
C PLOT EACH CHARACTER
DO 100 I=1,NCHR
IC=ICHR(I)
IF(IC.EQ.1000)THEN
C PLOT A SPACE
XI=XI+20.*RSCALE*CO
YI=YI+20.*RSCALE*SI
XO=XI
YO=YI
CALL HSTYLUS(XI,YI,IUP)
ELSEIF ((IC.EQ.1001).OR.(IC.EQ.1002))THEN
C BEGIN SUPER-SCRIPTING OR SUB-SCRIPTING
RAISE(L)=SUPSUB(IC-1000)*HEIGHT*RSCALE/SCALE
RSCALE=FACTOR*RSCALE
YOFF=RAISE(L)+YOFF
L=L+1
ELSEIF (IC.EQ.1003)THEN
C END SUPER/SUB-SCRIPTING
RSCALE=RSCALE/FACTOR
L=L-1
YOFF=YOFF-RAISE(L)
ELSEIF (IC.EQ.1004)THEN
C BACKSPACE -USE THE WIDTH OF THE PREVIOUS LETTER IN OLDWID.
XI=XI - CO*OLDWID
YI=YI - SI*OLDWID
XO=XI
YO=YI
ELSE
C PLOT A SINGLE SYMBOL
IS=ISTART(IC)
IB=30
70 IPEN=IXTRCT(IB,3,SYMBCD(IS))
IF(IPEN.EQ.0)THEN
XI=XI+CO*RSCALE*WIDTH(IC)
YI=YI+SI*RSCALE*WIDTH(IC)
XO=XI
YO=YI
OLDWID=WIDTH(IC)*RSCALE
GOTO 100
ENDIF
IX=IXTRCT(IB-3,6,SYMBCD(IS))
IY=IXTRCT(IB-9,6,SYMBCD(IS))
XX=(IX-10)*RSCALE
YY=(IY-11)*RSCALE+YOFF
CALL HSTYLUS(XI+CO*XX-SI*YY,YI+CO*YY+SI*XX,IPEN)
IB=45-IB
IF(IB.EQ.30)IS=IS+1
GOTO 70
ENDIF
100 CONTINUE
ENDIF
RETURN
END
SUBROUTINE CHRCOD(TEXT,NTEXT)
C GIVEN TEXT STRING IN TEXT, NTEXT CHARACTERS
C RETURNS ICHR CONTAINING NCHR SYMBOL NUMBERS OR CODES FOR
C SPACE (1000), BEGIN SUPERSCRIPTING (1001), BEGIN
C SUBSCRIPTING (1002), END SUPER/SUB-SCRIPTING (1003)
C BACKSPACE (1004), VECTOR (1005), OR HAT (1006)
C CHANGE OF FONT COMMANDS ARE DECODED AND EXECUTED INTERNALLY
C
COMMON /OFFSET/ IOFF,JUST1,JUST2
COMMON /AJUST/NCHR,ICHR(350)
CHARACTER*(*) TEXT
INTEGER IRLU(95),IILU(95),IGLU(26)
DATA IOFF/0/
C IRLU IS A LOOK-UP TABLE FOR ROMAN CHARACTERS ARRANGED BY
C INTEGER VALUE FOR THE ASCII CHARACTER SET WITH AN
C OFFSET TO REMOVE THE 31 NONPRINTING CONTROL CHARACTERS.
C IRLU RETURNS WITH THE SYMBOL NUMBER OR, IF NO SYMBOL
C EXISTS, THE CODE FOR SPACE.
DATA IRLU/1000,416,428,411,72,418,419,432,67,68,69,63,70,
$ 64,71,65,53,54,55,56,57,58,59,60,61,62,414,415,
$ 385,66,386,417,407,1,2,3,4,5,6,7,8,9,10,11,12,13,
$ 14,15,16,17,18,19,20,21,22,23,24,25,26,409,1000,
$ 410,408,1000,1000,27,28,29,30,31,32,33,34,35,36,
$ 37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,
$ 405,427,406,424/
C IILU IS A LOOK-UP TABLE FOR ITALIC CHARACTERS ONLY. IT IS
C IDENTICAL TO IRLU WITH FOUR ITALIC SPECIAL SYMBOLS SUBSTITUTED
C FOR REGULAR ONES.
DATA IILU/1000,422,1000,411,72,418,419,1000,67,68,69,63,70,
$ 64,71,65,53,54,55,56,57,58,59,60,61,62,420,421,
$ 385,66,386,423,407,1,2,3,4,5,6,7,8,9,10,11,12,13,
$ 14,15,16,17,18,19,20,21,22,23,24,25,26,409,1000,
$ 410,1000,1000,1000,27,28,29,30,31,32,33,34,35,36,
$ 37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,
$ 405,427,406,424/
C IGLU IS A LOOK-UP TABLE FOR GREEK CHARACTERS ARRANGED BY THE
C INTEGER VALUE OF THEIR ROMAN EXPRESSION WITH A=1, B=2, ETC.
C AMBIGUOUS CASES GIVE 25 FOR EPSILON OR ETA, 26 FOR OMEGA OR
C OMICRON, 27 FOR PHI,PI,OR PSI, AND 28 FOR TAU OR THETA. ADDITIONAL
C LETTERS MUST BE CHECKED FOR THESE CASE. A VALUE OF 50 IS RETURNED
C FOR THOSE ROMAN LETTERS WHICH HAVE NO CORRESPONDING GREEK LETTER.
DATA IGLU/1,2,22,4,25,50,3,50,9,50,10,11,12,13,26,27,50,17,18,
$ 28,20,50,50,14,50,6/
C FINDS LENGTH OF STRING WITH BLANKS TRIMMED FROM RIGHT END.
DO 10 N=NTEXT,1,-1
10 IF(TEXT(N:N).NE.' ')GOTO 15
NCHR=0
RETURN
15 NT=N
C SCAN TEXT CHARACTER BY CHARACTER
K=1
J=1
C K IS CURRENT ADDRESS OF CHARACTER IN TEXT
C J IS INDEX OF NEXT SYMBOL CODE IN ICHR
20 IF(K.GT.N)THEN
NCHR=J-1
RETURN
ENDIF
IF(TEXT(K:K).NE.'\\')THEN
C ROMAN CHARACTER OR KEYBOARD SYMBOL
IF(TEXT(K:K).EQ.'}')THEN
C CHECK FOR CLOSING CURLY BRACKET-IF FOUND, RETURN 1003
ICHR(J)=1003
J=J+1
K=K+1
GOTO 20
ENDIF
C ICHAR RETURNS INTEGER ASCII VALUE OF CHARACTER
C OFFSET BY NONPRINTING CHARACTERS TO GET ENTRY IN LOOK-UP TABLE
IC=ICHAR(TEXT(K:K))-ICHAR(' ')+1
IF(IC.LE.0)THEN
C NONPRINTING CONTROL CHARACTER-ERROR RETURN
ICHR(J)=1000
ELSEIF (IOFF.NE.240)THEN
C NOT ITALIC FONT
ICHR(J)=IRLU(IC)
ELSE
C ITALIC FONT
ICHR(J)=IILU(IC)
ENDIF
C ADD OFFSET FOR FONT IF NOT A SPECIAL SYMBOL
IF(ICHR(J).LT.385)ICHR(J)=ICHR(J)+IOFF
J=J+1
K=K+1
GOTO 20
ELSE
C BACKSLASH FOUND
C CHECK NEXT FOUR CHARACTERS FOR FOUR DIGIT NUMBER
K=K+1
READ(TEXT(K:K+3),25,ERR=50)NUMBER
25 FORMAT(I4)
C NUMBER FOUND-CHECK ITS VALIDITY
IC=NUMBER-1000
IF((IC.GT.0).AND.(IC.LT.433))THEN
C VALID SYMBOL CODE
ICHR(J)=IC
ELSEIF ((IC.GT.999).AND.(IC.LT.1004))THEN
C VALID COMMAND CODE
ICHR(J)=IC
ELSE
C NOT RECOGNIZED-ERROR RETURN
ICHR(J)=1000
ENDIF
J=J+1
C MOVE BEYOND CLOSING BACKSLASH-IGNORE EXTRA CHARACTERS
C FUNCTION INDEX RETURNS OFFSET OF SECOND SUBSTRING IN FIRST
C RETURNS 0 IF SUBSTRING NOT FOUND
L=INDEX(TEXT(K:NT),'\\')
IF(L.EQ.0)THEN
K=NT+1
ELSE
K=K+L
ENDIF
GOTO 20
50 CONTINUE
C NOT A NUMBER
C CHECK FOR FONT CHANGE COMMAND
IF(TEXT(K:K+2).EQ.'SIM'.OR.TEXT(K:K+2).EQ.'sim')THEN
C SIMPLEX FONT
IOFF=0
ELSEIF(TEXT(K:K+1).EQ.'CO'.OR.TEXT(K:K+1).EQ.'co')THEN
C COMPLEX FONT
IOFF=120
ELSEIF(TEXT(K:K+1).EQ.'IT'.OR.TEXT(K:K+1).EQ.'it')THEN
C ITALIC FONT
IOFF=240
ELSEIF (TEXT(K:K+1).EQ.'DU'.OR.TEXT(K:K+1).EQ.'du')THEN
C DUPLEX FONT
IOFF=312
C FOUND THE BACK-SPACE CODE
ELSEIF(TEXT(K:K+1).EQ.'BS'.OR.TEXT(K:K+1).EQ.'bs') THEN
ICHR(J)=1004
J=J+1
K=K+3
GO TO 20
C CHECK FOR SUPER/SUB-SCRIPT COMMAND
ELSEIF(TEXT(K:K+3).EQ.'SUP{'.OR.TEXT(K:K+3).EQ.'sup{')THEN
C BEGIN SUPERSCRIPTING
ICHR(J)=1001
J=J+1
K=K+4
GOTO 20
ELSEIF (TEXT(K:K+3).EQ.'SUB{'.OR.TEXT(K:K+3).EQ.'sub{')THEN
C BEGIN SUBSCRIPTING
ICHR(J)=1002
J=J+1
K=K+4
GOTO 20
ELSE
C GREEK CHARACTER OR INVALID CHARACTER
IC=ICHAR(TEXT(K:K))
IGOFF=MIN0(IOFF, 120)
IF(IOFF.EQ.312)IGOFF=0
IF((IC.GE.ICHAR('A')).AND.(IC.LE.ICHAR('Z')))THEN
C UPPER CASE
IGR=72
ICO=ICHAR('A')-1
ELSEIF((IC.GE.ICHAR('a')).AND.(IC.LE.ICHAR('z')))THEN
C LOWER CASE
IGR=96
ICO=ICHAR('a')-1
ELSE
C NOT A LETTER-ERROR RETURN
ICHR(J)=1000
J=J+1
L=INDEX(TEXT(K:NT),'\\')
IF(L.EQ.0)THEN
K=NT+1
ELSE
K=K+L
ENDIF
GOTO 20
ENDIF
C LOOK UP THE CHARACTER
IG=IGLU(IC-ICO)
IF(IG.LT.25)THEN
C UNAMBIGUOUS GREEK LETTER
ICHR(J)=IG+IGR+IGOFF
ELSEIF (IG.EQ.25)THEN
C EPSILON OR ETA
IB=ICHAR(TEXT(K+1:K+1))-ICO
IF(IB.EQ.16)THEN
C EPSILON
ICHR(J)=5+IGR+IGOFF
ELSEIF (IB.EQ.20)THEN
C ETA
ICHR(J)=7+IGR+IGOFF
ELSE
C NOT A GREEK CHARACTER--ERROR RETURN
ICHR(J)=1000
ENDIF
ELSEIF (IG.EQ.26)THEN
C OMEGA OR OMICRON
IB=ICHAR(TEXT(K+1:K+1))-ICO
IF(IB.NE.13)THEN
C NOT A GREEK CHARACTER-ERROR RETURN
ICHR(J)=1000
ELSE
IC=ICHAR(TEXT(K+2:K+2))-ICO
IF(IC.EQ.5)THEN
C OMEGA
ICHR(J)=24+IGR+IGOFF
ELSEIF (IC.EQ.9)THEN
C OMICRON
ICHR(J)=15+IGR+IGOFF
ELSE
C NOT A GREEK CHARACTER-ERROR RETURN
ICHR(J)=1000
ENDIF
ENDIF
ELSEIF (IG.EQ.27)THEN
C PHI,PI, OR PSI
IB=ICHAR(TEXT(K+1:K+1))-ICO
IF(IB.EQ.8)THEN
C PHI
ICHR(J)=21+IGR+IGOFF
ELSEIF (IB.EQ.9)THEN
C PI
ICHR(J)=16+IGR+IGOFF
ELSEIF (IB.EQ.19)THEN
C PSI
ICHR(J)=23+IGR+IGOFF
ELSE
C NOT A GREEK CHARACTER-ERROR RETURN
ICHR(J)=1000
ENDIF
ELSEIF (IG.EQ.28)THEN
C TAU OR THETA
IB=ICHAR(TEXT(K+1:K+1))-ICO
IF(IB.EQ.1)THEN
C TAU
ICHR(J)=19+IGR+IGOFF
ELSEIF(IB.EQ.8)THEN
C THETA
ICHR(J)=8+IGR+IGOFF
ELSE
C NOT A GREEK CHARACTER-ERROR RETURN
ICHR(J)=1000
ENDIF
ELSE
C NOT A GREEK CHARACTER-ERROR RETURN
ICHR(J)=1000
ENDIF
J=J+1
ENDIF
L=INDEX(TEXT(K:NT),'\\')
IF(L.EQ.0)THEN
K=NT+1
ELSE
K=K+L
ENDIF
GOTO 20
ENDIF
RETURN
END
SUBROUTINE JUSTFY(S, HEIGHT, ITEXT, NTEXT)
C$$$$ CALLS CHRCOD
C GIVEN THE
C TEXT STRING ITEXT WITH NTEXT CHARACTERS, HEIGHT HEIGHT, THIS ROUTINE
C GIVES 4 DISTANCES IN INCHES, ALL FROM THE LEFT END OF THE STRING -
C S(1) TO THE LEFT EDGE OF THE 1ST NONBLANK CHARACTER
C S(2) TO THE CENTER OF THE THE STRING, BLANKS REMOVED FROM THE ENDS
C S(3) TO THE RIGHT EDGE OF THE LAST NONBLANK CHARACTER
C S(4) TO THE RIGHT EDGE OF THE LAST CHARACTER OF THE STRING.
CHARACTER*350 TEXT
DIMENSION S(4),IPOWER(3),ITEXT(350),WIDTH(432)
COMMON /IWID/ WIDTH
COMMON /OFFSET/ IOFF,JUST1,JUST2
COMMON /AJUST/NCHR,ICHR(350)
DATA IPOWER/1,1,-1/,FACTOR/0.75/
C
NTXT=NTEXT
SCALE=HEIGHT/21.0
JQUART=(NTEXT+3)/4
C TRANSLATE INTEGER STRING INTO CHARACTER VARIABLE, THEN GET POINTERS
C INTO THE ARRAY ICHR.
C
K=1
DO 90 J=1,JQUART
WRITE(TEXT(K:K+3),100)ITEXT(J)
90 K=K+4
100 FORMAT(A4)
CALL CHRCOD(TEXT,NTXT)
C
C COUNT LEADING BLANKS.
DO 1100 LEAD=1,NCHR
1100 IF(ICHR(LEAD).NE.1000)GOTO 1110
LEAD=NTXT
1110 S(1)=20.0*SCALE*(LEAD-1)
S(3)=S(1)
C
C SUM THE WIDTHS OF THE REMAINING TEXT, RECALLING THAT TRAILING BLANKS
C WERE LOPPED OFF BY CHRCOD.
OLDWID=0.0
DO 1200 I=LEAD,NCHR
L=ICHR(I)
IF (L.LT.1000) THEN
OLDWID=WIDTH(L)*SCALE
S(3)=S(3) + OLDWID
ENDIF
IF(L.EQ.1000)S(3)=S(3)+20.0*SCALE
IF(L.GE.1001.AND.L.LE.1003)SCALE=SCALE*FACTOR**IPOWER(L-1000)
1200 IF(L.EQ.1004)S(3)=S(3)-OLDWID
C
C ADD ON WIDTH OF SURPLUS TRAILING BLANKS.
S(4)=S(3)+20.0*SCALE*(NTXT-NCHR)
C
C FIND CENTER OF NONBLANK TEXT.
S(2)=(S(1)+S(3))/2.0
JUST2=1
RETURN
END