Trailing-Edge
-
PDP-10 Archives
-
decuslib10-08
-
43,50476/datext.for
There are 2 other files named datext.for in the archive. Click here to see a list.
SUBROUTINE DATEXT(LINE ,JSTIFY,IFILL ,INTRVL,MOVE ,
1 ISPACE,LTTR ,LTRBGN,LTREND,LFTCOL,IWIDTH,MAXBFR,
2 IBUFFR,MAXUSD,MAXLIN,LTRNXT)
C RENBR(/CONSTRUCT LARGE MULTI-LINE LETTERING)
C
C DONALD BARTH, CHEMISTRY DEPT., HARVARD UNIVERSITY
C DEVELOPED AT AIKEN COMPUTER LABORATORY
C
C DDDDD AAA TTTTTTTT EEEEEEEE XX XX TTTTTTTT
C DD DD AAAA TT EE XX XX TT
C DD DD AA AA TT EE XXXX TT
C DD DD AA AA TT EEEEE XX TT
C DD DD AAAAAAA TT EE XXXX TT
C DD DD AA AA TT EE XX XX TT
C DDDDD AA AA TT EEEEEEEE XX XX TT
C
C ROUTINE TO PRODUCE MULTIPLE LINE PRINTED LETTERING
C SIMILAR TO THAT USED FOR THE ABOVE TITLE.
C
C THIS ROUTINE MUST BE USED WITH A BLOCK DATA FONT
C CREATED BY THE PROGRAM DAFONT.
C
C LINE = THE LINE WITHIN THE LETTER REPRESENTATION
C WHICH IS TO BE PLACED INTO IBUFFR.
C CHARACTERS ARE A TOTAL OF IHIGH LINES HIGH.
C TO PRINT A LETTER OR LETTERS, IT IS
C NECESSARY TO CALL DATEXT IHIGH TIMES WITH
C LINE VALUES 1 THROUGH IHIGH, WITH THE
C CALLING PROGRAM PRINTING IBUFFR ARRAY AFTER
C EACH RETURN FROM DATEXT. THIS ALLOWS THE
C INSERTION OF THE CONSTRUCTED LETTERS INTO
C OTHER TEXT OR OTHER FORMS.
C = 0, REPRESENT HIGHEST VALUED LINE. LINE MUST
C BE SET TO MAXLIN-1 BEFORE THIS ROUTINE IS
C AGAIN CALLED.
C JSTIFY = -1, LEFT JUSTIFY THE LETTER REPRESENTATIONS
C IN A FIELD OF WIDTH IWIDTH.
C = 0, CENTER THE LETTER REPRESENTATIONS IN A
C FIELD OF WIDTH IWIDTH.
C = 1, RIGHT JUSTIFY THE LETTER REPRESENTATIONS
C IN A FIELD OF WIDTH IWIDTH.
C IFILL = 0, IF LEFT JUSITIFYING OR CENTERING THE
C LETTERING, DO NOT FILL THE UNUSED PORTION OF
C THE FIELD RIGHT OF LETTER REPRESENTATIONS
C WITH SPACES. MAXUSD WILL BE LEFT POINTING TO
C RIGHT END OF RIGHTMOST LETTER REPESENTATION.
C = 1, IF LEFT JUSIFYING OR CENTERING THE LETTER
C REPRESENTATIONS, DO FILL THE UNUSED PORTION
C OF FIELD RIGHT OF LETTER REPRESENTATIONS
C WITH SPACES. MAXUSD WILL BE LEFT POINTING
C LFTCOL+IWIDTH.
C INTRVL = THE NUMBER OF SPACE (BLANK) CHARACTERS TO BE
C INSERTED BETWEEN REPRESENTED CHARACTERS
C MOVE = -2, CHARACTERS WHICH ARE NARROWER THAN THE
C WIDEST CHARACTER ARE CENTERED WITHIN WIDTH
C OF WIDEST CHARACTER. NO WHITE SPACE ADJUST-
C MENT OF POSITIONS IS TO BE MADE. SPACES
C WILL ALSO BE WIDTH OF THE WIDEST CHARACTER.
C = -1, CHARACTERS WHICH ARE NARROWER THAN MOST
C COMMON WIDTH WILL BE CENTERED WITHIN MOST
C COMMON WIDTH. NO WHITE SPACE ADJUSTMENT OF
C POSITIONS IS TO BE MADE. SPACES WILL ALSO
C BE WIDTH WHICH IS MOST COMMON.
C = 0, NORMAL INTER-CHARACTER SPACING IS ACCEPT-
C ABLE WITHOUT WHITE SPACE ADJUSTMENT.
C = 1, ADJUST SPACE BETWEEN CHARACTERS TO EQUAL-
C IZE WHITE SPACES.
C ISPACE = -1, REPRESENT BOTH INITIAL AND FINAL SPACES
C IN LTTR ARRAY.
C = 0, REPRESENT INITIAL SPACES IN LTTR ARRAY.
C SUPPRESS FINAL SPACES IN LTTR ARRAY.
C = 1, SUPPRESS BOTH INITIAL AND FINAL SPACES IN
C LTTR ARRAY.
C LTTR = ARRAY CONTAINING LETTERS TO BE REPRESENTED,
C 1 LETTER PER WORD, AS READ BY MULTIPLE OF A1
C FORMAT. SINCE THE LETTERING PRODUCED BY
C THIS ROUTINE IS LARGE, TERMINAL SPACES ARE
C IGNORED UNLESS ISPACE=-1. NOTE THAT MAXUSD
C EQUALS LFTCOL IF LTTR CONTAINS ONLY SPACES,
C AND ISPACE IS GREATER THAN OR EQUAL TO ZERO,
C AND IFILL IS EQUAL TO ZERO.
C LTRBGN = SEQUENCE NUMBER WITHIN LTTR ARRAY OF FIRST
C LETTER TO BE REPRESENTED (THIS IS THE
C SUBSCRIPT OF THE LTTR ARRAY AT WHICH THE
C FIRST LETTER IS TO BE FOUND)
C LTREND = SEQUENCE NUMBER WITHIN LTTR ARRAY OF FINAL
C LETTER TO BE REPRESENTED (THIS IS THE
C SUBSCRIPT OF THE LTTR ARRAY AT WHICH THE
C FINAL LETTER IS TO BE FOUND)
C LFTCOL = SUBSCRIPT OF OUTPUT BUFFER ARRAY LOCATION TO
C LEFT OF 1ST LOCATION INTO WHICH THIS ROUTINE
C CAN PLACE REPRESENTATION OF CONTENTS OF LTTR
C ARRAY.
C IWIDTH = THE WIDTH OF THE FIELD INTO WHICH THE LETTER
C REPRESENTATIONS CAN BE PLACED. THE MAXIMUM
C VALUE WITH WHICH MAXUSD CAN THEN BE RETURNED
C IS LFTCOL+IWIDTH OR MAXBFR, WHICHEVER IS THE
C SMALLER.
C MAXBFR = MAXIMUM SUBSCRIPT OF IBUFFR ARRAY LOCATION
C INTO WHICH CAN BE PLACED REPRESENTATION
C OF CONTENTS OF LTTR ARRAY.
C
C THE FOLLOWING ARGUMENTS ARE USED FOR OUTPUT.
C
C IBUFFR = THE ARRAY INTO WHICH IS TO BE PLACED THE
C REPRESENTATION OF THE LETTERS IN LTTR.
C MAXUSD = RETURNED BY DATEXT CONTAINING THE NEW NUMBER
C OF LOCATIONS IN USE AFTER THE LETTERS IN
C LTTR HAVE BEEN REPRESENTED IN IBUFFR.
C MAXLIN = RETURNED CONTAINING THE MAXIMUM VALUE WHICH
C LINE CAN ATTAIN (IHIGH). THIS WILL DEPEND
C ON WHICH FONT HAS BEEN LOADED. MAXLIN IS
C RETURNED AS ZERO IF FONT HAS NOT BEEN LOADED
C LTRNXT = RETURNED CONTAINING THE SUBSCRIPT WITHIN THE
C LTTR ARRAY OF THE FIRST LETTER WHICH WAS NOT
C REPRESENTED. IF ALL LETTERS REQUESTED WERE
C REPRESENTED THEN LTRNXT WILL EQUAL LTREND+1.
C IF NOT ALL LETTERS COULD BE REPRESENTED DUE
C TO THE VALUE OF IWIDTH BEING TOO SMALL, THEN
C LTRNXT WILL POINT TO THE FIRST LETTER WHICH
C WOULD NOT FIT.
C
COMMON/FASPG/KNTLTR,IHIGH,IWIDE,JWIDE,LOCK,
1LETTER(96),LENGTH(96),IPACKD(672)
C
DIMENSION LTTR(LTREND),IBUFFR(MAXBFR),IDIGIT(10)
DATA IDIGIT/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
DATA KOMAND,IVRTCL,IHRZNT,IEQUAL,IEND,IUPPER,
1LOWER,NARROW,IFIXED,IADJST,NWIDE,IBLANK/
21H$,1HV,1HH,1H=,1HE,1HU,1HL,1HN,1HF,1HA,1HW,1H /
C
LTRNXT=LTRBGN
MAXUSD=LFTCOL
IF(LOCK.NE.999)GO TO 61
MAXLIN=IHIGH
NOWLIN=LINE
IF(NOWLIN.LE.0)NOWLIN=IHIGH
IF(NOWLIN.GT.IHIGH)GO TO 62
IUSED=LFTCOL
IWHITE=MOVE
KWIDE=IWIDE
IF(IWHITE.LE.-2)KWIDE=JWIDE
JSPACE=INTRVL
IF(JSPACE.LT.0)JSPACE=0
LAST=0
KSPACE=0
NEED=0
MAXKNT=IUSED+IWIDTH
IF(MAXKNT.GT.MAXBFR)MAXKNT=MAXBFR
IFCASE=1
NOWVRT=1
NOWHRZ=1
KASATO=0
LWIDE=KWIDE
NOWTST=0
GO TO 3
C
C FIND OUT IF CAN REPRESENT THE LETTER
1 KSPACE=JSPACE
LAST=MATCH
LSTVRT=NOWVRT
LSTHRZ=NOWHRZ
LSTLNG=NOWLNG
2 LTRNXT=LTRNXT+1
3 IF(LTRNXT.GT.LTREND)GO TO 57
NOWLTR=LTTR(LTRNXT)
IF(NOWLTR.EQ.IBLANK)GO TO 7
IF(NOWLTR.EQ.KOMAND)GO TO 13
4 MATCH=0
KNTKAS=0
5 MATCH=MATCH+1
IF(MATCH.GT.KNTLTR)GO TO 6
IF(NOWLTR.NE.LETTER(MATCH))GO TO 5
KNTKAS=KNTKAS+1
IF(KNTKAS.GE.IFCASE)GO TO 26
LSTKAS=MATCH
GO TO 5
6 IF(KNTKAS.GT.0)GO TO 25
GO TO 8
C
C REPRESENT SPACE OR UNKNOWN CHARACTER
7 IF(KASATO.GE.0)GO TO 8
KASATO=-KASATO
IFCASE=KASATO-IFCASE
8 IF(ISPACE.LE.0)GO TO 9
IF(LAST.EQ.0)GO TO 2
9 KSPACE=KSPACE+LWIDE
IF(ISPACE.GE.0)GO TO 12
I=KSPACE
IF(IWHITE.LE.0)GO TO 10
IF(LAST.NE.0)I=I-JSPACE
10 IF((IUSED+I).GT.MAXKNT)GO TO 57
11 IF(I.LE.0)GO TO 12
I=I-1
KSPACE=KSPACE-1
IUSED=IUSED+1
IBUFFR(IUSED)=IBLANK
GO TO 11
12 IF(IWHITE.LE.0)KSPACE=KSPACE+JSPACE
GO TO 2
C
C DOLLAR CONTROL CHARACTER FOUND
13 LTRNXT=LTRNXT+1
IF(LTRNXT.GT.LTREND)GO TO 57
NOWLTR=LTTR(LTRNXT)
IF(NOWLTR.EQ.KOMAND)GO TO 4
IF(NOWLTR.EQ.IVRTCL)GO TO 16
IF(NOWLTR.EQ.IHRZNT)GO TO 17
IF(NOWLTR.EQ.IEQUAL)GO TO 15
IF(NOWLTR.EQ.IFIXED)GO TO 18
IF(NOWLTR.EQ.IADJST)GO TO 19
IF(NOWLTR.EQ.NARROW)GO TO 20
IF(NOWLTR.EQ.NWIDE)GO TO 21
IF(NOWLTR.EQ.IEND)GO TO 22
IF(NOWLTR.EQ.IUPPER)GO TO 23
IF(NOWLTR.EQ.LOWER)GO TO 24
DO 14 I=2,10
IF(NOWLTR.NE.IDIGIT(I))GO TO 14
IFCASE=I-1
KASATO=0
GO TO 2
14 CONTINUE
GO TO 2
15 NOWVRT=1
NOWHRZ=1
IFCASE=1
KASATO=0
LWIDE=KWIDE
IWHITE=MOVE
GO TO 2
16 NOWVRT=-1
GO TO 2
17 NOWHRZ=-1
GO TO 2
18 IF(IWHITE.GT.0)IWHITE=0
GO TO 2
19 IF(IWHITE.EQ.0)IWHITE=1
GO TO 2
20 LWIDE=KWIDE/2
GO TO 2
21 LWIDE=(3*KWIDE)/2
GO TO 2
22 IF(KASATO.LT.0)IFCASE=-KASATO-IFCASE
KASATO=0
GO TO 2
23 IF(KASATO.EQ.0)KASATO=(4*((IFCASE+1)/2))-1
IF(KASATO.GT.0)GO TO 2
KASATO=-KASATO
IFCASE=KASATO-IFCASE
GO TO 2
24 IF(KASATO.LT.0)GO TO 2
IF(KASATO.EQ.0)KASATO=(4*((IFCASE+1)/2))-1
IFCASE=KASATO-IFCASE
KASATO=-KASATO
GO TO 2
C
C PREPARE TO PLOT CHARACTER
25 MATCH=LSTKAS
26 IF(KASATO.LE.0)GO TO 27
IFCASE=KASATO-IFCASE
KASATO=-KASATO
27 NOWLNG=LENGTH(MATCH)
C
C DETERMINE OPTIMUM SPACING
C
C SKIP AROUND THIS CODE IF NORMAL
C INTER-CHARACTER SPACING IS ACCEPTABLE
C WITHOUT WHITE AREA ADJUSTMENT.
C THE CALCULATIONS ARE DESIGNED TO PRODUCE
C DISTANCES OF THE SORT
C
C 4
C 34
C 234
C 1234
C 01234
C X01234
C 01234
C 1234
C 234
C 34
C 4
C
C THE FIRST LOOP CATCHES THE MOST COMMON CASE OF
C 2 CHARACTERS TOUCHING ON THE SAME LINE. THE
C SECOND LONGER LOOP CATCHES THIS CASE AND ALL
C OTHERS AND COULD BE USED BY ITSELF.
IF(IWHITE.LT.0)GO TO 46
IF(JSPACE.EQ.0)GO TO 47
LSTTST=NOWTST
NOWTST=2**(NOWLNG-1)
IF(LAST.EQ.0)GO TO 47
IF(IWHITE.EQ.0)GO TO 47
MIN=JSPACE
ISTART=IHIGH*(LAST-1)
JSTART=IHIGH*(MATCH-1)
IF(LSTVRT.EQ.NOWVRT)GO TO 28
LSTVRT=-1
ISTART=ISTART+IHIGH+1
GO TO 29
28 LSTVRT=1
29 IINDEX=ISTART
JINDEX=JSTART
DO 33 I=1,IHIGH
IINDEX=IINDEX+LSTVRT
JINDEX=JINDEX+1
K=IPACKD(IINDEX)
IF(LSTHRZ.LT.0)GO TO 30
IF(K.EQ.(2*(K/2)))GO TO 33
GO TO 31
30 IF(K.LT.LSTTST)GO TO 33
31 K=IPACKD(JINDEX)
IF(NOWHRZ.GT.0)GO TO 32
IF(K.EQ.(2*(K/2)))GO TO 33
GO TO 47
32 IF(K.GE.NOWTST)GO TO 47
33 CONTINUE
DO 45 I=1,IHIGH
ISTART=ISTART+LSTVRT
K=IPACKD(ISTART)
IF(K.EQ.0)GO TO 45
IF(LSTHRZ.GT.0)GO TO 35
IDIST=LSTLNG
34 K=K/2
IDIST=IDIST-1
IF(K.NE.0)GO TO 34
GO TO 37
35 IDIST=0
36 L=K/2
IF((L+L).NE.K)GO TO 37
K=L
IDIST=IDIST+1
GO TO 36
37 N=JSTART
DO 44 J=1,IHIGH
N=N+1
K=IPACKD(N)
IF(K.EQ.0)GO TO 44
IF(NOWHRZ.GT.0)GO TO 39
JDIST=IDIST
38 L=K/2
IF((L+L).NE.K)GO TO 41
K=L
JDIST=JDIST+1
GO TO 38
39 JDIST=IDIST+NOWLNG
40 K=K/2
JDIST=JDIST-1
IF(K.NE.0)GO TO 40
41 IF(I.GT.J)GO TO 42
IF(I.EQ.J)GO TO 43
JDIST=JDIST+J-I-1
GO TO 43
42 JDIST=JDIST+I-J-1
43 IF(MIN.LE.JDIST)GO TO 44
IF(JDIST.LE.0)GO TO 47
MIN=JDIST
44 CONTINUE
45 CONTINUE
KSPACE=KSPACE-MIN
GO TO 47
C
C ADJUST CENTERING OF NARROW CHARACTERS IF NEEDED
46 IF(NOWLNG.GE.KWIDE)GO TO 47
IF((IUSED+KSPACE+KWIDE).GT.MAXKNT)GO TO 57
NEED=(KWIDE-NOWLNG)/2
KSPACE=KSPACE+NEED
NEED=KWIDE-NEED-NOWLNG
C
C CONSTRUCT LETTER
47 IF((IUSED+KSPACE+NOWLNG).GT.MAXKNT)GO TO 57
48 IF(KSPACE.LE.0)GO TO 49
KSPACE=KSPACE-1
IUSED=IUSED+1
IBUFFR(IUSED)=IBLANK
GO TO 48
49 I=(IHIGH*(MATCH-1))+NOWLIN
IF(NOWVRT.LT.0)I=(IHIGH*MATCH)-NOWLIN+1
I=IPACKD(I)
LIMIT=NOWLNG
IF(NOWHRZ.LT.0)GO TO 53
IUSED=IUSED+NOWLNG
J=IUSED
50 IF(LIMIT.LE.0)GO TO 56
LIMIT=LIMIT-1
K=I/2
IF((K+K).EQ.I)GO TO 51
IBUFFR(J)=NOWLTR
GO TO 52
51 IBUFFR(J)=IBLANK
52 J=J-1
I=K
GO TO 50
53 IF(LIMIT.LE.0)GO TO 56
LIMIT=LIMIT-1
IUSED=IUSED+1
K=I/2
IF((K+K).EQ.I)GO TO 54
IBUFFR(IUSED)=NOWLTR
GO TO 55
54 IBUFFR(IUSED)=IBLANK
55 I=K
GO TO 53
56 IF(NEED.LE.0)GO TO 1
NEED=NEED-1
IUSED=IUSED+1
IBUFFR(IUSED)=IBLANK
GO TO 56
C
C ALL LETTERS REPRESENTED, JUSTIFY AND FILL
57 NEED=0
IF(JSTIFY.GE.0)NEED=MAXKNT-IUSED
IF(JSTIFY.EQ.0)NEED=NEED/2
NEED=IUSED+NEED
INIKNT=MAXUSD
MAXUSD=NEED
IF(IFILL.GT.0)MAXUSD=MAXKNT
I=MAXUSD
58 IF(I.LE.NEED)GO TO 59
IBUFFR(I)=IBLANK
I=I-1
GO TO 58
59 IF(IUSED.LE.INIKNT)GO TO 60
IBUFFR(I)=IBUFFR(IUSED)
I=I-1
IUSED=IUSED-1
GO TO 59
60 IF(I.LE.INIKNT)GO TO 62
IBUFFR(I)=IBLANK
I=I-1
GO TO 60
C
C RETURN TO CALLING PROGRAM
61 MAXLIN=0
62 RETURN
C545790969953$
END