Hershey Fonts in Fortran 77 part 1 of 2

sources-request at panda.UUCP sources-request at panda.UUCP
Wed Mar 12 22:12:21 AEST 1986


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 at sdcsvax.ucsd.edu
	ihnp4  >---  sdcsvax  --- brian
	ucbvax/		Kantor at 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



More information about the Mod.sources mailing list