Path: seismo!harvard!talcott!panda!sources-request From: sources-request@panda.UUCP Newsgroups: mod.sources Subject: Hershey Fonts in Fortran 77 part 1 of 2 Message-ID: <1508@panda.UUCP> Date: 12 Mar 86 12:12:21 GMT Sender: jpn@panda.UUCP Lines: 577 Approved: jpn@panda.UUCP 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