home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume4 / hershey.f77 / part1 next >
Internet Message Format  |  1986-11-30  |  19KB
  1. From: talcott!seismo!s3sun!sdcsvax!brian (Brian Kantor)
  2. Subject: Hershey Fonts in Fortran 77 part 1 of 2
  3. Newsgroups: mod.sources
  4. Approved: jpn@panda.UUCP
  5.  
  6. Mod.sources:  Volume 4, Issue 25
  7. Submitted by: seismo!s3sun!sdcsvax!brian (Brian Kantor)
  8.  
  9.  
  10. The following is a fortran-77 subroutine called 'symbol' which will use the
  11. Public-Domain Hershey fonts to draw letters, numbers, and symbols.  It is
  12. in use here at UCSD in connection with several plotting packages for lettering
  13. and for point plotting.
  14.  
  15. Part 2 of this distribution contains the BLOCKDATA statements which
  16. form the actual fonts themselves, and a description of the format in
  17. which they are stored.
  18.  
  19. I contacted the authors of this subroutine and obtained their permission to
  20. distribute the subroutine.  I'm in the process of writing a 'c' subroutine 
  21. to also use the Hershey data.  I will submit that for posting when I'm
  22. done.
  23.  
  24.     Brian Kantor    UCSD Computer Graphics Lab
  25.             c/o B-028, La Jolla, CA 92093 (619) 452-6865
  26.  
  27.     decvax\     brian@sdcsvax.ucsd.edu
  28.     ihnp4  >---  sdcsvax  --- brian
  29.     ucbvax/        Kantor@Nosc 
  30. -------------------------------------------------------------------------------
  31.  
  32.       SUBROUTINE HERSHEY(X,Y,HEIGHT,ITEXT,THETA,NTEXT)
  33. C
  34. C  FEATURES:
  35. C    1) FOUR HERSHEY LETTER FONTS--SIMPLEX,COMPLEX,ITALIC, AND DUPLEX--
  36. C       ARE PROVIDED IN UPPER AND LOWER CASE ROMAN
  37. C    2) TWO HERSHEY LETTER FONTS--SIMPLEX AND COMPLEX--ARE PROVIDED IN
  38. C       UPPER AND LOWER CASE GREEK
  39. C    3) 47 SPECIAL MATHEMATICAL SYMBOLS, E.G. INTEGRAL SIGN,DEL, ARE
  40. C       PROVIDED
  41. C    4) SUPER- AND SUB-SCRIPTING IS POSSIBLE WITHIN A CHARACTER STRING
  42. C       WITHOUT SEPARATE CALLS TO SYMBOL
  43. C
  44. C   CHANGE OF FONT IS MADE BY ENCLOSING THE NAME OF THE FONT IN UPPER
  45. C  CASE IN BACKSLASHES, E.G \SIMPLEX\.  THREE LETTERS SUFFICE TO
  46. C  SPECIFY THE FONT.  SIMPLEX IS THE DEFAULT FONT ON THE INITIAL CALL
  47. C  TO SYMBOL.  A FONT REMAINS IN EFFECT UNTIL EXPLICITLY CHANGED.
  48. C   SUPER- OR SUB-SCRIPTING IS ACCOMPLISHED BY ENCLOSING THE EXPRESSION
  49. C  TO BE SUPER- OR SUB-SCRIPTED IN CURLY BRACKETS AND PRECEDING IT BY
  50. C  SUP OR SUB. THE CLOSING CURLY BRACKET TERMINATES THE
  51. C  SUPER- OR SUB-SCRIPTING AND RETURNS TO NORMAL CHARACTER PLOTTING.
  52. C  NOTE THAT SUPER- AND SUB-SCRIPT LETTERS ARE PLOTTED WITH A
  53. C  DIFFERENT CHARACTER SIZE.
  54. C    GREEK LETTERS ARE DRAWN  BY ENCLOSING THE ENGLISH NAME OF THE
  55. C  LETTER IN BACKSLASHES, E.G. \ALPHA\.  THE CASE OF THE FIRST LETTER
  56. C  DETERMINES THE CASE OF THE GREEK LETTER.  THE CLOSING BACKSLASH MUST
  57. C  BE INCLUDED.
  58. C   ANY SYMBOL MAY BE CALLED BY ENCLOSING THE SYMBOL NUMBER+1000 IN
  59. C  BACKSLASHES.  THIS IS THE ONLY WAY TO CALL SOME SYMBOLS, ESPECIALLY
  60. C  SPECIAL MATHEMATICAL SYMBOLS.
  61. C   THE SYMBOL NUMBERS ARE
  62. C   1-26   UPPER CASE ROMAN SIMPLEX
  63. C  27-52   LOWER CASE ROMAN SIMPLEX
  64. C  53-72   SIMPLEX NUMBERS AND SYMBOLS
  65. C  73-96   UPPER CASE GREEK SIMPLEX
  66. C  97-120  LOWER CASE GREEK SIMPLEX
  67. C  121-146 UPPER CASE ROMAN COMPLEX
  68. C  147-172 LOWER CASE ROMAN COMPLEX
  69. C  173-192 COMPLEX NUMBERS AND SYMBOLS
  70. C  193-216 UPPER CASE GREEK COMPLEX
  71. C  217-240 LOWER CASE GREEK COMPLEX
  72. C  241-266 UPPER CASE ROMAN ITALIC
  73. C  267-292 LOWER CASE ROMAN ITALIC
  74. C  293-312 ITALIC NUMBERS AND SYMBOLS
  75. C  313-338 UPPER CASE ROMAN DUPLEX
  76. C  339-364 LOWER CASE ROMAN DUPLEX
  77. C  365-384 DUPLEX NUMBERS AND SYMBOLS
  78. C  385-432 SPECIAL MATHEMATICAL SYMBOLS
  79. C  ADDITIONAL FEATURES ADDED FEB 1982
  80.  
  81. C  THE PEN MAY BE MOVED BACK TO THE START POINT FOR THE PREVIOUS
  82. C  CHARACTER BY \BS\.  THIS IS USEFUL, FOR EXAMPLE, IN WRITING
  83. C  INTEGRAL SIGNS WITH LIMITS ABOVE AND BELOW THEM.
  84. C
  85. C  SYMBOL PARAMETERS TAKEN FROM N.M.WOLCOTT, FORTRAN IV ENHANCED
  86. C  CHARACTER GRAPHICS, NBS
  87. C
  88. C  A.CHAVE IGPP/UCSD AUG 1981, MODIFIED FEB 1982 BY A. CHAVE,
  89. C                              R.L. PARKER, AND L. SHURE
  90. C
  91. C  X,Y ARE THE COORDINATES IN INCHES FROM THE CURRENT ORIGIN TO THE
  92. C  LOWER LEFT CORNER OF THE 1ST CHARACTER TO BE PLOTTED.  IF EITHER
  93. C  IS SET TO 999.0 THEN SAVED NEXT CHARACTER POSITION IS USED.
  94. C  HEIGHT IS THE CHARACTER HEIGHT IN INCHES
  95. C  ITEXT IS AN INTEGER ARRAY CONTAINING THE TEXT TO BE PLOTTED
  96. C  THETA IS THE POSITIVE CCW ANGLE W.R.T. THE X-AXIS
  97. C  NTEXT IS THE NUMBER OF CHARACTERS IN ITEXT TO PLOT
  98. C    IF NTEXT.LT.-1 THE PEN IS DOWN TO (X,Y) AND A SINGLE SPECIAL
  99. C    CENTERED SYMBOL IS PLOTTED. IF NTEXT.EQ.-1 THE PEN IS UP TO
  100. C    (X,Y) AND A SINGLE SPECIAL CENTERED SYMBOL IS PLOTTED. IF
  101. C    NTEXT=0 A SINGLE SIMPLEX ROMAN CHARACTER FROM ITEXT, LEFT-
  102. C    JUSTIFIED, IS PLOTTED. IF NTEXT.GT.0 NTEXT CHARACTERS FROM
  103. C    ITEXT ARE DECODED AND NCHR CHARACTERS ARE PLOTTED WHERE
  104. C    NCHR.LE.NTEXT TO REMOVE BACKSLASHES, COMMAND CODES, ETC.
  105. C
  106. C  PROGRAMMED IN FORTRAN-77
  107. C
  108.       CHARACTER TEXT*350
  109.       INTEGER ITEXT(1)
  110.       INTEGER ISTART(432),ISSTAR(22),SYMBCD(4711),SSYMBC(128)
  111.       REAL WIDTH(432),SUPSUB(2),RAISE(20)
  112.       COMMON /OFFSET/ IOFF,JUST1,JUST2
  113.       COMMON /AJUST/ NCHR,ICHR(350)
  114.       COMMON /IALPH/ SYMBCD,ISTART,SSYMBC,ISSTAR
  115.       COMMON /IWID/ WIDTH
  116.       PARAMETER (PI=3.1415926,RAD=PI/180.)
  117.       SAVE XO,YO
  118.       DATA FACTOR/0.75/,SUPSUB/0.50,-0.50/,  IUP,IDOWN/3,2/
  119. C  ICHR(J) CONTAINS THE SYMBOL NUMBER OF THE JTH SYMBOL OR A
  120. C  CODE TO INDICATE SPACE (1000),BEGIN SUPER-SCRIPTING (1001),
  121. C  BEGIN SUB-SCRIPTING (1002), OR END SUPER/SUB-SCRIPTING (1003),
  122. C  OR BACK-SPACE (1004).
  123. C  ISTART(ICHR(J)) CONTAINS THE ADDRESS IN SYMBOL OF THE JTH
  124. C  CHARACTER.  SYMBCD CONTAINS THE PEN INSTRUCTIONS STORED IN A
  125. C  SPECIAL FORMAT.  ISSTAR AND SSYMBC CONTAIN ADDRESSES AND PEN
  126. C  INSTRUCTIONS FOR THE SPECIAL CENTERED SYMBOLS.  WIDTH CONTAINS
  127. C  THE WIDTHS OF THE CHARACTERS.
  128. C
  129. C  IXTRCT GETS NBITS FROM IWORD STARTING AT THE NSTART BIT FROM THE
  130. C  RIGHT
  131.       IXTRCT(NSTART,NBITS,IWORD)=MOD(IWORD/(2**(NSTART-NBITS)),
  132.      $                           2**NBITS)+((1-ISIGN(1,IWORD))/2)*
  133.      $                           (2**NBITS-MIN0(1,MOD(-IWORD,
  134.      $                           2**(NSTART-NBITS))))
  135. C
  136.       YOFF=0.0
  137.       SI=SIN(RAD*THETA)
  138.       CO=COS(RAD*THETA)
  139.       SCALE=HEIGHT/21.
  140.       IF(SCALE.EQ.0.0)RETURN
  141.       IF(X.GE.999.0)THEN
  142.        XI=XO
  143.       ELSE
  144.        XI=X
  145.       ENDIF
  146.       IF(Y.GE.999.0)THEN
  147.        YI=YO
  148.       ELSE
  149.        YI=Y
  150.       ENDIF
  151.       IF(NTEXT.LT.0)THEN
  152. C  PLOT A SINGLE SPECIAL CENTERED SYMBOL
  153.        IF(NTEXT.LT.-1)CALL HSTYLUS(XI,YI,IDOWN)
  154.        IA=ITEXT(1)+1
  155.        IS=ISSTAR(IA)
  156.        IB=30
  157.    20  IPEN=IXTRCT(IB,3,SSYMBC(IS))
  158.        IF(IPEN.EQ.0)THEN
  159.          CALL HSTYLUS(XI,YI,IUP)
  160.          XI=XI+20.0*CO
  161.          YI=YI+20.0*SI
  162.          XO=XI
  163.          YO=YI
  164.          RETURN
  165.        ENDIF
  166.        IX=IXTRCT(IB-3,6,SSYMBC(IS))
  167.        IY=IXTRCT(IB-9,6,SSYMBC(IS))
  168.        XX=SCALE*(IX-32)
  169.        YY=SCALE*(IY-32)
  170.        CALL HSTYLUS(XI+XX*CO-YY*SI,YI+XX*SI+YY*CO,IPEN)
  171.        IB=45-IB
  172.        IF(IB.EQ.30)IS=IS+1
  173.        GOTO 20
  174.       ELSEIF (NTEXT.EQ.0)THEN
  175. C PLOT A SINGLE SIMPLEX ROMAN CHARACTER
  176.         ISAV=IOFF
  177.         IOFF=0
  178.           WRITE(TEXT(1:1),25)ITEXT(1)
  179.    25 FORMAT(A1)
  180.         CALL CHRCOD(TEXT,1)
  181.         IOFF=ISAV
  182.         IS=ISTART(ICHR(1))
  183.         IB=30
  184.    40   IPEN=IXTRCT(IB,3,SYMBCD(IS))
  185.         IF(IPEN.EQ.0)THEN
  186.           XI=XI+CO*SCALE*WIDTH(ICHR(1))
  187.           YI=YI+SI*SCALE*WIDTH(ICHR(1))
  188.           XO=XI
  189.           YO=YI
  190.           RETURN
  191.         ENDIF
  192.         IX=IXTRCT(IB-3,6,SYMBCD(IS))
  193.         IY=IXTRCT(IB-9,6,SYMBCD(IS))
  194.         XX=(IX-10)*SCALE
  195.         YY=(IY-11)*SCALE
  196.         CALL HSTYLUS(XI+CO*XX-SI*YY,YI+CO*YY+SI*XX,IPEN)
  197.         IB=45-IB
  198.         IF(IB.EQ.30)IS=IS+1
  199.         GOTO 40
  200.       ELSE
  201. C  PLOT A CHARACTER STRING.
  202. C  FIRST FIND POINTER ARRAY  ICHR  CONTAINING THE STARTS OF CHARACTERS-
  203. C  BUT ONLY IF  JUST1 AND JUST2  ARE NOT 1, WHEN  ICHR IS ASSUMED
  204. C  CORRECTLY TRANSMITTED THROUGH COMMON /AJUST/.
  205.         IF(JUST1.NE.1.OR.JUST2.NE.1)THEN
  206.           N=NTEXT
  207.           K=1
  208.           DO 50 I=1,N
  209.               WRITE(TEXT(I:I),55)ITEXT(I)
  210.    50       K=K+1
  211.    55 FORMAT(A1)
  212.           CALL CHRCOD(TEXT,N)
  213.         ENDIF
  214.         JUST2=2
  215.         OLDWID=0.0
  216.         L=1
  217.         RSCALE=SCALE
  218. C  PLOT EACH CHARACTER
  219.         DO 100 I=1,NCHR
  220.         IC=ICHR(I)
  221.         IF(IC.EQ.1000)THEN
  222. C  PLOT A SPACE
  223.           XI=XI+20.*RSCALE*CO
  224.           YI=YI+20.*RSCALE*SI
  225.           XO=XI
  226.           YO=YI
  227.           CALL HSTYLUS(XI,YI,IUP)
  228.         ELSEIF ((IC.EQ.1001).OR.(IC.EQ.1002))THEN
  229. C  BEGIN SUPER-SCRIPTING OR SUB-SCRIPTING
  230.           RAISE(L)=SUPSUB(IC-1000)*HEIGHT*RSCALE/SCALE
  231.           RSCALE=FACTOR*RSCALE
  232.           YOFF=RAISE(L)+YOFF
  233.           L=L+1
  234.         ELSEIF (IC.EQ.1003)THEN
  235. C  END SUPER/SUB-SCRIPTING
  236.           RSCALE=RSCALE/FACTOR
  237.           L=L-1
  238.           YOFF=YOFF-RAISE(L)
  239.         ELSEIF (IC.EQ.1004)THEN
  240. C  BACKSPACE -USE THE WIDTH OF THE PREVIOUS LETTER IN OLDWID.
  241.           XI=XI - CO*OLDWID
  242.           YI=YI - SI*OLDWID
  243.           XO=XI
  244.           YO=YI
  245.         ELSE
  246. C PLOT A SINGLE SYMBOL
  247.           IS=ISTART(IC)
  248.           IB=30
  249.    70     IPEN=IXTRCT(IB,3,SYMBCD(IS))
  250.           IF(IPEN.EQ.0)THEN
  251.             XI=XI+CO*RSCALE*WIDTH(IC)
  252.             YI=YI+SI*RSCALE*WIDTH(IC)
  253.             XO=XI
  254.             YO=YI
  255.             OLDWID=WIDTH(IC)*RSCALE
  256.             GOTO 100
  257.           ENDIF
  258.           IX=IXTRCT(IB-3,6,SYMBCD(IS))
  259.           IY=IXTRCT(IB-9,6,SYMBCD(IS))
  260.           XX=(IX-10)*RSCALE
  261.           YY=(IY-11)*RSCALE+YOFF
  262.           CALL HSTYLUS(XI+CO*XX-SI*YY,YI+CO*YY+SI*XX,IPEN)
  263.           IB=45-IB
  264.           IF(IB.EQ.30)IS=IS+1
  265.           GOTO 70
  266.         ENDIF
  267.   100   CONTINUE
  268.       ENDIF
  269.       RETURN
  270.       END
  271.       SUBROUTINE CHRCOD(TEXT,NTEXT)
  272. C  GIVEN TEXT STRING IN TEXT, NTEXT CHARACTERS
  273. C  RETURNS ICHR CONTAINING NCHR SYMBOL NUMBERS OR CODES FOR
  274. C  SPACE (1000), BEGIN SUPERSCRIPTING (1001), BEGIN
  275. C  SUBSCRIPTING (1002), END SUPER/SUB-SCRIPTING (1003)
  276. C  BACKSPACE (1004), VECTOR (1005), OR HAT (1006)
  277. C  CHANGE OF FONT COMMANDS ARE DECODED AND EXECUTED INTERNALLY
  278. C
  279.       COMMON /OFFSET/ IOFF,JUST1,JUST2
  280.       COMMON /AJUST/NCHR,ICHR(350)
  281.       CHARACTER*(*) TEXT
  282.       INTEGER IRLU(95),IILU(95),IGLU(26)
  283.       DATA IOFF/0/
  284. C  IRLU IS A LOOK-UP TABLE FOR ROMAN CHARACTERS ARRANGED BY
  285. C  INTEGER VALUE FOR THE ASCII CHARACTER SET WITH AN
  286. C  OFFSET TO REMOVE THE 31 NONPRINTING CONTROL CHARACTERS.
  287. C  IRLU RETURNS WITH THE SYMBOL NUMBER OR, IF NO SYMBOL
  288. C  EXISTS, THE CODE FOR SPACE.
  289.       DATA IRLU/1000,416,428,411,72,418,419,432,67,68,69,63,70,
  290.      $          64,71,65,53,54,55,56,57,58,59,60,61,62,414,415,
  291.      $          385,66,386,417,407,1,2,3,4,5,6,7,8,9,10,11,12,13,
  292.      $          14,15,16,17,18,19,20,21,22,23,24,25,26,409,1000,
  293.      $          410,408,1000,1000,27,28,29,30,31,32,33,34,35,36,
  294.      $          37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,
  295.      $          405,427,406,424/
  296. C  IILU IS A LOOK-UP TABLE FOR ITALIC CHARACTERS ONLY.  IT IS
  297. C  IDENTICAL TO IRLU WITH FOUR ITALIC SPECIAL SYMBOLS SUBSTITUTED
  298. C  FOR REGULAR ONES.
  299.       DATA IILU/1000,422,1000,411,72,418,419,1000,67,68,69,63,70,
  300.      $          64,71,65,53,54,55,56,57,58,59,60,61,62,420,421,
  301.      $          385,66,386,423,407,1,2,3,4,5,6,7,8,9,10,11,12,13,
  302.      $          14,15,16,17,18,19,20,21,22,23,24,25,26,409,1000,
  303.      $          410,1000,1000,1000,27,28,29,30,31,32,33,34,35,36,
  304.      $          37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,
  305.      $          405,427,406,424/
  306. C  IGLU IS A LOOK-UP TABLE FOR GREEK CHARACTERS ARRANGED BY THE
  307. C  INTEGER VALUE OF THEIR ROMAN EXPRESSION WITH A=1, B=2, ETC.
  308. C  AMBIGUOUS CASES GIVE 25 FOR EPSILON OR ETA, 26 FOR OMEGA OR
  309. C  OMICRON, 27 FOR PHI,PI,OR PSI, AND 28 FOR TAU OR THETA.  ADDITIONAL
  310. C  LETTERS MUST BE CHECKED FOR THESE CASE.  A VALUE OF 50 IS RETURNED
  311. C  FOR THOSE ROMAN LETTERS WHICH HAVE NO CORRESPONDING GREEK LETTER.
  312.       DATA IGLU/1,2,22,4,25,50,3,50,9,50,10,11,12,13,26,27,50,17,18,
  313.      $             28,20,50,50,14,50,6/
  314. C FINDS LENGTH OF STRING WITH BLANKS TRIMMED FROM RIGHT END.
  315.       DO 10 N=NTEXT,1,-1
  316.  10     IF(TEXT(N:N).NE.' ')GOTO 15
  317.       NCHR=0
  318.       RETURN
  319.  15   NT=N
  320. C  SCAN TEXT CHARACTER BY CHARACTER
  321.       K=1
  322.       J=1
  323. C  K IS CURRENT ADDRESS OF CHARACTER IN TEXT
  324. C  J IS INDEX OF NEXT SYMBOL CODE IN ICHR
  325.    20 IF(K.GT.N)THEN
  326.         NCHR=J-1
  327.         RETURN
  328.       ENDIF
  329.       IF(TEXT(K:K).NE.'\\')THEN
  330. C  ROMAN CHARACTER OR KEYBOARD SYMBOL
  331.         IF(TEXT(K:K).EQ.'}')THEN
  332. C  CHECK FOR CLOSING CURLY BRACKET-IF FOUND, RETURN 1003
  333.           ICHR(J)=1003
  334.           J=J+1
  335.           K=K+1
  336.           GOTO 20
  337.         ENDIF
  338. C  ICHAR RETURNS INTEGER ASCII VALUE OF CHARACTER
  339. C  OFFSET BY NONPRINTING CHARACTERS TO GET ENTRY IN LOOK-UP TABLE
  340.         IC=ICHAR(TEXT(K:K))-ICHAR(' ')+1
  341.         IF(IC.LE.0)THEN
  342. C  NONPRINTING CONTROL CHARACTER-ERROR RETURN
  343.           ICHR(J)=1000
  344.         ELSEIF (IOFF.NE.240)THEN
  345. C  NOT ITALIC FONT
  346.           ICHR(J)=IRLU(IC)
  347.         ELSE
  348. C  ITALIC FONT
  349.           ICHR(J)=IILU(IC)
  350.         ENDIF
  351. C  ADD OFFSET FOR FONT IF NOT A SPECIAL SYMBOL
  352.         IF(ICHR(J).LT.385)ICHR(J)=ICHR(J)+IOFF
  353.           J=J+1
  354.           K=K+1
  355.           GOTO 20
  356.         ELSE
  357. C  BACKSLASH FOUND
  358. C  CHECK NEXT FOUR CHARACTERS FOR FOUR DIGIT NUMBER
  359.           K=K+1
  360.             READ(TEXT(K:K+3),25,ERR=50)NUMBER
  361.    25 FORMAT(I4)
  362. C  NUMBER FOUND-CHECK ITS VALIDITY
  363.           IC=NUMBER-1000
  364.           IF((IC.GT.0).AND.(IC.LT.433))THEN
  365. C  VALID SYMBOL CODE
  366.             ICHR(J)=IC
  367.           ELSEIF ((IC.GT.999).AND.(IC.LT.1004))THEN
  368. C  VALID COMMAND CODE
  369.             ICHR(J)=IC
  370.           ELSE
  371. C NOT RECOGNIZED-ERROR RETURN
  372.             ICHR(J)=1000
  373.           ENDIF
  374.           J=J+1
  375. C  MOVE BEYOND CLOSING BACKSLASH-IGNORE EXTRA CHARACTERS
  376. C  FUNCTION INDEX RETURNS OFFSET OF SECOND SUBSTRING IN FIRST
  377. C  RETURNS 0 IF SUBSTRING NOT FOUND
  378.            L=INDEX(TEXT(K:NT),'\\')
  379.            IF(L.EQ.0)THEN
  380.              K=NT+1
  381.            ELSE
  382.              K=K+L
  383.            ENDIF
  384.            GOTO 20
  385.    50      CONTINUE
  386. C  NOT A NUMBER
  387. C  CHECK FOR FONT CHANGE COMMAND
  388.          IF(TEXT(K:K+2).EQ.'SIM'.OR.TEXT(K:K+2).EQ.'sim')THEN
  389. C  SIMPLEX FONT
  390.            IOFF=0
  391.          ELSEIF(TEXT(K:K+1).EQ.'CO'.OR.TEXT(K:K+1).EQ.'co')THEN
  392. C  COMPLEX FONT
  393.            IOFF=120
  394.          ELSEIF(TEXT(K:K+1).EQ.'IT'.OR.TEXT(K:K+1).EQ.'it')THEN
  395. C  ITALIC FONT
  396.            IOFF=240
  397.          ELSEIF (TEXT(K:K+1).EQ.'DU'.OR.TEXT(K:K+1).EQ.'du')THEN
  398. C  DUPLEX FONT
  399.            IOFF=312
  400. C  FOUND THE BACK-SPACE CODE
  401.          ELSEIF(TEXT(K:K+1).EQ.'BS'.OR.TEXT(K:K+1).EQ.'bs') THEN
  402.            ICHR(J)=1004
  403.            J=J+1
  404.            K=K+3
  405.            GO TO 20
  406. C  CHECK FOR SUPER/SUB-SCRIPT COMMAND
  407.          ELSEIF(TEXT(K:K+3).EQ.'SUP{'.OR.TEXT(K:K+3).EQ.'sup{')THEN
  408. C  BEGIN SUPERSCRIPTING
  409.            ICHR(J)=1001
  410.            J=J+1
  411.            K=K+4
  412.            GOTO 20
  413.          ELSEIF (TEXT(K:K+3).EQ.'SUB{'.OR.TEXT(K:K+3).EQ.'sub{')THEN
  414. C  BEGIN SUBSCRIPTING
  415.            ICHR(J)=1002
  416.            J=J+1
  417.            K=K+4
  418.            GOTO 20
  419.          ELSE
  420. C  GREEK CHARACTER OR INVALID CHARACTER
  421.            IC=ICHAR(TEXT(K:K))
  422.            IGOFF=MIN0(IOFF, 120)
  423.            IF(IOFF.EQ.312)IGOFF=0
  424.            IF((IC.GE.ICHAR('A')).AND.(IC.LE.ICHAR('Z')))THEN
  425. C  UPPER CASE
  426.              IGR=72
  427.              ICO=ICHAR('A')-1
  428.            ELSEIF((IC.GE.ICHAR('a')).AND.(IC.LE.ICHAR('z')))THEN
  429. C  LOWER CASE
  430.              IGR=96
  431.              ICO=ICHAR('a')-1
  432.            ELSE
  433. C  NOT A LETTER-ERROR RETURN
  434.              ICHR(J)=1000
  435.              J=J+1
  436.              L=INDEX(TEXT(K:NT),'\\')
  437.              IF(L.EQ.0)THEN
  438.                K=NT+1
  439.              ELSE
  440.                K=K+L
  441.              ENDIF
  442.              GOTO 20
  443.            ENDIF
  444. C  LOOK UP THE CHARACTER
  445.            IG=IGLU(IC-ICO)
  446.            IF(IG.LT.25)THEN
  447. C  UNAMBIGUOUS GREEK LETTER
  448.              ICHR(J)=IG+IGR+IGOFF
  449.            ELSEIF (IG.EQ.25)THEN
  450. C  EPSILON OR ETA
  451.              IB=ICHAR(TEXT(K+1:K+1))-ICO
  452.              IF(IB.EQ.16)THEN
  453. C  EPSILON
  454.                ICHR(J)=5+IGR+IGOFF
  455.              ELSEIF (IB.EQ.20)THEN
  456. C  ETA
  457.                ICHR(J)=7+IGR+IGOFF
  458.              ELSE
  459. C  NOT A GREEK CHARACTER--ERROR RETURN
  460.                ICHR(J)=1000
  461.              ENDIF
  462.          ELSEIF (IG.EQ.26)THEN
  463. C  OMEGA OR OMICRON
  464.            IB=ICHAR(TEXT(K+1:K+1))-ICO
  465.            IF(IB.NE.13)THEN
  466. C NOT A GREEK CHARACTER-ERROR RETURN
  467.              ICHR(J)=1000
  468.            ELSE
  469.              IC=ICHAR(TEXT(K+2:K+2))-ICO
  470.              IF(IC.EQ.5)THEN
  471. C  OMEGA
  472.                ICHR(J)=24+IGR+IGOFF
  473.              ELSEIF (IC.EQ.9)THEN
  474. C  OMICRON
  475.                ICHR(J)=15+IGR+IGOFF
  476.              ELSE
  477. C  NOT A GREEK CHARACTER-ERROR RETURN
  478.                ICHR(J)=1000
  479.              ENDIF
  480.            ENDIF
  481.          ELSEIF (IG.EQ.27)THEN
  482. C  PHI,PI, OR PSI
  483.            IB=ICHAR(TEXT(K+1:K+1))-ICO
  484.            IF(IB.EQ.8)THEN
  485. C  PHI
  486.              ICHR(J)=21+IGR+IGOFF
  487.            ELSEIF (IB.EQ.9)THEN
  488. C  PI
  489.              ICHR(J)=16+IGR+IGOFF
  490.            ELSEIF (IB.EQ.19)THEN
  491. C  PSI
  492.              ICHR(J)=23+IGR+IGOFF
  493.            ELSE
  494. C  NOT A GREEK CHARACTER-ERROR RETURN
  495.              ICHR(J)=1000
  496.            ENDIF
  497.            ELSEIF (IG.EQ.28)THEN
  498. C TAU OR THETA
  499.              IB=ICHAR(TEXT(K+1:K+1))-ICO
  500.              IF(IB.EQ.1)THEN
  501. C  TAU
  502.                ICHR(J)=19+IGR+IGOFF
  503.              ELSEIF(IB.EQ.8)THEN
  504. C  THETA
  505.                ICHR(J)=8+IGR+IGOFF
  506.              ELSE
  507. C  NOT A GREEK CHARACTER-ERROR RETURN
  508.                ICHR(J)=1000
  509.              ENDIF
  510.            ELSE
  511. C  NOT A GREEK CHARACTER-ERROR RETURN
  512.              ICHR(J)=1000
  513.            ENDIF
  514.           J=J+1
  515.         ENDIF
  516.         L=INDEX(TEXT(K:NT),'\\')
  517.         IF(L.EQ.0)THEN
  518.           K=NT+1
  519.         ELSE
  520.           K=K+L
  521.         ENDIF
  522.         GOTO 20
  523.       ENDIF
  524.       RETURN
  525.       END
  526.       SUBROUTINE JUSTFY(S, HEIGHT, ITEXT, NTEXT)
  527. C$$$$ CALLS CHRCOD
  528. C  GIVEN THE
  529. C  TEXT STRING  ITEXT  WITH  NTEXT  CHARACTERS, HEIGHT  HEIGHT,  THIS ROUTINE
  530. C  GIVES 4 DISTANCES IN INCHES, ALL FROM THE LEFT END OF THE STRING -
  531. C  S(1)  TO THE LEFT EDGE OF THE 1ST NONBLANK CHARACTER
  532. C  S(2)  TO THE CENTER OF THE THE STRING, BLANKS REMOVED FROM THE ENDS
  533. C  S(3)  TO THE RIGHT EDGE OF THE LAST NONBLANK CHARACTER
  534. C  S(4)  TO THE RIGHT EDGE OF THE LAST CHARACTER OF THE STRING.
  535.       CHARACTER*350 TEXT
  536.       DIMENSION S(4),IPOWER(3),ITEXT(350),WIDTH(432)
  537.       COMMON /IWID/ WIDTH
  538.       COMMON /OFFSET/ IOFF,JUST1,JUST2
  539.       COMMON /AJUST/NCHR,ICHR(350)
  540.       DATA IPOWER/1,1,-1/,FACTOR/0.75/
  541. C
  542.       NTXT=NTEXT
  543.       SCALE=HEIGHT/21.0
  544.       JQUART=(NTEXT+3)/4
  545. C  TRANSLATE INTEGER STRING INTO CHARACTER VARIABLE, THEN GET POINTERS
  546. C  INTO THE ARRAY  ICHR.
  547. C
  548.       K=1
  549.       DO 90 J=1,JQUART
  550.           WRITE(TEXT(K:K+3),100)ITEXT(J)
  551.   90    K=K+4
  552.  100  FORMAT(A4)
  553.       CALL CHRCOD(TEXT,NTXT)
  554. C
  555. C  COUNT LEADING BLANKS.
  556.       DO 1100 LEAD=1,NCHR
  557.  1100 IF(ICHR(LEAD).NE.1000)GOTO 1110
  558.       LEAD=NTXT
  559.  1110 S(1)=20.0*SCALE*(LEAD-1)
  560.       S(3)=S(1)
  561. C
  562. C  SUM THE WIDTHS OF THE REMAINING TEXT, RECALLING THAT TRAILING BLANKS
  563. C  WERE LOPPED OFF BY  CHRCOD.
  564.       OLDWID=0.0
  565.       DO 1200 I=LEAD,NCHR
  566.       L=ICHR(I)
  567.       IF (L.LT.1000) THEN
  568.         OLDWID=WIDTH(L)*SCALE
  569.         S(3)=S(3) + OLDWID
  570.       ENDIF
  571.       IF(L.EQ.1000)S(3)=S(3)+20.0*SCALE
  572.       IF(L.GE.1001.AND.L.LE.1003)SCALE=SCALE*FACTOR**IPOWER(L-1000)
  573.  1200 IF(L.EQ.1004)S(3)=S(3)-OLDWID
  574. C
  575. C  ADD ON WIDTH OF SURPLUS TRAILING BLANKS.
  576.       S(4)=S(3)+20.0*SCALE*(NTXT-NCHR)
  577. C
  578. C  FIND CENTER OF NONBLANK TEXT.
  579.       S(2)=(S(1)+S(3))/2.0
  580.       JUST2=1
  581.       RETURN
  582.       END
  583.  
  584.