Trailing-Edge
-
PDP-10 Archives
-
decuslib20-05
-
decus/20-0141/datext.for
There are 2 other files named datext.for in the archive. Click here to see a list.
00100 SUBROUTINE DATEXT(LINE ,JSTIFY,IFILL ,INTRVL,MOVE ,
00200 1 ISPACE,LTTR ,LTRBGN,LTREND,LFTCOL,IWIDTH,MAXBFR,
00300 2 IBUFFR,MAXUSD,MAXLIN,LTRNXT)
00400 C RENBR(/CONSTRUCT LARGE MULTI-LINE LETTERING)
00500 C
00600 C DONALD BARTH, CHEMISTRY DEPT., HARVARD UNIVERSITY
00700 C DEVELOPED AT AIKEN COMPUTER LABORATORY
00800 C
00900 C DDDDD AAA TTTTTTTT EEEEEEEE XX XX TTTTTTTT
01000 C DD DD AAAA TT EE XX XX TT
01100 C DD DD AA AA TT EE XXXX TT
01200 C DD DD AA AA TT EEEEE XX TT
01300 C DD DD AAAAAAA TT EE XXXX TT
01400 C DD DD AA AA TT EE XX XX TT
01500 C DDDDD AA AA TT EEEEEEEE XX XX TT
01600 C
01700 C ROUTINE TO PRODUCE MULTIPLE LINE PRINTED LETTERING
01800 C SIMILAR TO THAT USED FOR THE ABOVE TITLE.
01900 C
02000 C THIS ROUTINE MUST BE USED WITH A BLOCK DATA FONT
02100 C CREATED BY THE PROGRAM DAFONT.
02200 C
02300 C LINE = THE LINE WITHIN THE LETTER REPRESENTATION
02400 C WHICH IS TO BE PLACED INTO IBUFFR.
02500 C CHARACTERS ARE A TOTAL OF IHIGH LINES HIGH.
02600 C TO PRINT A LETTER OR LETTERS, IT IS
02700 C NECESSARY TO CALL DATEXT IHIGH TIMES WITH
02800 C LINE VALUES 1 THROUGH IHIGH, WITH THE
02900 C CALLING PROGRAM PRINTING IBUFFR ARRAY AFTER
03000 C EACH RETURN FROM DATEXT. THIS ALLOWS THE
03100 C INSERTION OF THE CONSTRUCTED LETTERS INTO
03200 C OTHER TEXT OR OTHER FORMS.
03300 C = 0, REPRESENT HIGHEST VALUED LINE. LINE MUST
03400 C BE SET TO MAXLIN-1 BEFORE THIS ROUTINE IS
03500 C AGAIN CALLED.
03600 C JSTIFY = -1, LEFT JUSTIFY THE LETTER REPRESENTATIONS
03700 C IN A FIELD OF WIDTH IWIDTH.
03800 C = 0, CENTER THE LETTER REPRESENTATIONS IN A
03900 C FIELD OF WIDTH IWIDTH.
04000 C = 1, RIGHT JUSTIFY THE LETTER REPRESENTATIONS
04100 C IN A FIELD OF WIDTH IWIDTH.
04200 C IFILL = 0, IF LEFT JUSITIFYING OR CENTERING THE
04300 C LETTERING, DO NOT FILL THE UNUSED PORTION OF
04400 C THE FIELD RIGHT OF LETTER REPRESENTATIONS
04500 C WITH SPACES. MAXUSD WILL BE LEFT POINTING TO
04600 C RIGHT END OF RIGHTMOST LETTER REPESENTATION.
04700 C = 1, IF LEFT JUSIFYING OR CENTERING THE LETTER
04800 C REPRESENTATIONS, DO FILL THE UNUSED PORTION
04900 C OF FIELD RIGHT OF LETTER REPRESENTATIONS
05000 C WITH SPACES. MAXUSD WILL BE LEFT POINTING
05100 C LFTCOL+IWIDTH.
05200 C INTRVL = THE NUMBER OF SPACE (BLANK) CHARACTERS TO BE
05300 C INSERTED BETWEEN REPRESENTED CHARACTERS
05400 C MOVE = -2, CHARACTERS WHICH ARE NARROWER THAN THE
05500 C WIDEST CHARACTER ARE CENTERED WITHIN WIDTH
05600 C OF WIDEST CHARACTER. NO WHITE SPACE ADJUST-
05700 C MENT OF POSITIONS IS TO BE MADE. SPACES
05800 C WILL ALSO BE WIDTH OF THE WIDEST CHARACTER.
05900 C = -1, CHARACTERS WHICH ARE NARROWER THAN MOST
06000 C COMMON WIDTH WILL BE CENTERED WITHIN MOST
06100 C COMMON WIDTH. NO WHITE SPACE ADJUSTMENT OF
06200 C POSITIONS IS TO BE MADE. SPACES WILL ALSO
06300 C BE WIDTH WHICH IS MOST COMMON.
06400 C = 0, NORMAL INTER-CHARACTER SPACING IS ACCEPT-
06500 C ABLE WITHOUT WHITE SPACE ADJUSTMENT.
06600 C = 1, ADJUST SPACE BETWEEN CHARACTERS TO EQUAL-
06700 C IZE WHITE SPACES.
06800 C ISPACE = -1, REPRESENT BOTH INITIAL AND FINAL SPACES
06900 C IN LTTR ARRAY.
07000 C = 0, REPRESENT INITIAL SPACES IN LTTR ARRAY.
07100 C SUPPRESS FINAL SPACES IN LTTR ARRAY.
07200 C = 1, SUPPRESS BOTH INITIAL AND FINAL SPACES IN
07300 C LTTR ARRAY.
07400 C LTTR = ARRAY CONTAINING LETTERS TO BE REPRESENTED,
07500 C 1 LETTER PER WORD, AS READ BY MULTIPLE OF A1
07600 C FORMAT. SINCE THE LETTERING PRODUCED BY
07700 C THIS ROUTINE IS LARGE, TERMINAL SPACES ARE
07800 C IGNORED UNLESS ISPACE=-1. NOTE THAT MAXUSD
07900 C EQUALS LFTCOL IF LTTR CONTAINS ONLY SPACES,
08000 C AND ISPACE IS GREATER THAN OR EQUAL TO ZERO,
08100 C AND IFILL IS EQUAL TO ZERO.
08200 C LTRBGN = SEQUENCE NUMBER WITHIN LTTR ARRAY OF FIRST
08300 C LETTER TO BE REPRESENTED (THIS IS THE
08400 C SUBSCRIPT OF THE LTTR ARRAY AT WHICH THE
08500 C FIRST LETTER IS TO BE FOUND)
08600 C LTREND = SEQUENCE NUMBER WITHIN LTTR ARRAY OF FINAL
08700 C LETTER TO BE REPRESENTED (THIS IS THE
08800 C SUBSCRIPT OF THE LTTR ARRAY AT WHICH THE
08900 C FINAL LETTER IS TO BE FOUND)
09000 C LFTCOL = SUBSCRIPT OF OUTPUT BUFFER ARRAY LOCATION TO
09100 C LEFT OF 1ST LOCATION INTO WHICH THIS ROUTINE
09200 C CAN PLACE REPRESENTATION OF CONTENTS OF LTTR
09300 C ARRAY.
09400 C IWIDTH = THE WIDTH OF THE FIELD INTO WHICH THE LETTER
09500 C REPRESENTATIONS CAN BE PLACED. THE MAXIMUM
09600 C VALUE WITH WHICH MAXUSD CAN THEN BE RETURNED
09700 C IS LFTCOL+IWIDTH OR MAXBFR, WHICHEVER IS THE
09800 C SMALLER.
09900 C MAXBFR = MAXIMUM SUBSCRIPT OF IBUFFR ARRAY LOCATION
10000 C INTO WHICH CAN BE PLACED REPRESENTATION
10100 C OF CONTENTS OF LTTR ARRAY.
10200 C
10300 C THE FOLLOWING ARGUMENTS ARE USED FOR OUTPUT.
10400 C
10500 C IBUFFR = THE ARRAY INTO WHICH IS TO BE PLACED THE
10600 C REPRESENTATION OF THE LETTERS IN LTTR.
10700 C MAXUSD = RETURNED BY DATEXT CONTAINING THE NEW NUMBER
10800 C OF LOCATIONS IN USE AFTER THE LETTERS IN
10900 C LTTR HAVE BEEN REPRESENTED IN IBUFFR.
11000 C MAXLIN = RETURNED CONTAINING THE MAXIMUM VALUE WHICH
11100 C LINE CAN ATTAIN (IHIGH). THIS WILL DEPEND
11200 C ON WHICH FONT HAS BEEN LOADED. MAXLIN IS
11300 C RETURNED AS ZERO IF FONT HAS NOT BEEN LOADED
11400 C LTRNXT = RETURNED CONTAINING THE SUBSCRIPT WITHIN THE
11500 C LTTR ARRAY OF THE FIRST LETTER WHICH WAS NOT
11600 C REPRESENTED. IF ALL LETTERS REQUESTED WERE
11700 C REPRESENTED THEN LTRNXT WILL EQUAL LTREND+1.
11800 C IF NOT ALL LETTERS COULD BE REPRESENTED DUE
11900 C TO THE VALUE OF IWIDTH BEING TOO SMALL, THEN
12000 C LTRNXT WILL POINT TO THE FIRST LETTER WHICH
12100 C WOULD NOT FIT.
12200 C
12300 COMMON/FASPG/KNTLTR,IHIGH,IWIDE,JWIDE,LOCK,
12400 1LETTER(96),LENGTH(96),IPACKD(1020)
12500 C
12600 DIMENSION LTTR(LTREND),IBUFFR(MAXBFR),IDIGIT(10)
12700 DATA IDIGIT/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
12800 DATA KOMAND,IVRTCL,IHRZNT,IEQUAL,IEND,IUPPER,
12900 1LOWER,NARROW,IFIXED,IADJST,NWIDE,IBLANK/
13000 21H$,1HV,1HH,1H=,1HE,1HU,1HL,1HN,1HF,1HA,1HW,1H /
13100 C
13200 LTRNXT=LTRBGN
13300 MAXUSD=LFTCOL
13400 IF(LOCK.NE.999)GO TO 61
13500 MAXLIN=IHIGH
13600 NOWLIN=LINE
13700 IF(NOWLIN.LE.0)NOWLIN=IHIGH
13800 IF(NOWLIN.GT.IHIGH)GO TO 62
13900 IUSED=LFTCOL
14000 IWHITE=MOVE
14100 KWIDE=IWIDE
14200 IF(IWHITE.LE.-2)KWIDE=JWIDE
14300 JSPACE=INTRVL
14400 IF(JSPACE.LT.0)JSPACE=0
14500 LAST=0
14600 KSPACE=0
14700 NEED=0
14800 MAXKNT=IUSED+IWIDTH
14900 IF(MAXKNT.GT.MAXBFR)MAXKNT=MAXBFR
15000 IFCASE=1
15100 NOWVRT=1
15200 NOWHRZ=1
15300 KASATO=0
15400 LWIDE=KWIDE
15500 NOWTST=0
15600 GO TO 3
15700 C
15800 C FIND OUT IF CAN REPRESENT THE LETTER
15900 1 KSPACE=JSPACE
16000 LAST=MATCH
16100 LSTVRT=NOWVRT
16200 LSTHRZ=NOWHRZ
16300 LSTLNG=NOWLNG
16400 2 LTRNXT=LTRNXT+1
16500 3 IF(LTRNXT.GT.LTREND)GO TO 57
16600 NOWLTR=LTTR(LTRNXT)
16700 IF(NOWLTR.EQ.IBLANK)GO TO 7
16800 IF(NOWLTR.EQ.KOMAND)GO TO 13
16900 4 MATCH=0
17000 KNTKAS=0
17100 5 MATCH=MATCH+1
17200 IF(MATCH.GT.KNTLTR)GO TO 6
17300 IF(NOWLTR.NE.LETTER(MATCH))GO TO 5
17400 KNTKAS=KNTKAS+1
17500 IF(KNTKAS.GE.IFCASE)GO TO 26
17600 LSTKAS=MATCH
17700 GO TO 5
17800 6 IF(KNTKAS.GT.0)GO TO 25
17900 GO TO 8
18000 C
18100 C REPRESENT SPACE OR UNKNOWN CHARACTER
18200 7 IF(KASATO.GE.0)GO TO 8
18300 KASATO=-KASATO
18400 IFCASE=KASATO-IFCASE
18500 8 IF(ISPACE.LE.0)GO TO 9
18600 IF(LAST.EQ.0)GO TO 2
18700 9 KSPACE=KSPACE+LWIDE
18800 IF(ISPACE.GE.0)GO TO 12
18900 I=KSPACE
19000 IF(IWHITE.LE.0)GO TO 10
19100 IF(LAST.NE.0)I=I-JSPACE
19200 10 IF((IUSED+I).GT.MAXKNT)GO TO 57
19300 11 IF(I.LE.0)GO TO 12
19400 I=I-1
19500 KSPACE=KSPACE-1
19600 IUSED=IUSED+1
19700 IBUFFR(IUSED)=IBLANK
19800 GO TO 11
19900 12 IF(IWHITE.LE.0)KSPACE=KSPACE+JSPACE
20000 GO TO 2
20100 C
20200 C DOLLAR CONTROL CHARACTER FOUND
20300 13 LTRNXT=LTRNXT+1
20400 IF(LTRNXT.GT.LTREND)GO TO 57
20500 NOWLTR=LTTR(LTRNXT)
20600 IF(NOWLTR.EQ.KOMAND)GO TO 4
20700 IF(NOWLTR.EQ.IVRTCL)GO TO 16
20800 IF(NOWLTR.EQ.IHRZNT)GO TO 17
20900 IF(NOWLTR.EQ.IEQUAL)GO TO 15
21000 IF(NOWLTR.EQ.IFIXED)GO TO 18
21100 IF(NOWLTR.EQ.IADJST)GO TO 19
21200 IF(NOWLTR.EQ.NARROW)GO TO 20
21300 IF(NOWLTR.EQ.NWIDE)GO TO 21
21400 IF(NOWLTR.EQ.IEND)GO TO 22
21500 IF(NOWLTR.EQ.IUPPER)GO TO 23
21600 IF(NOWLTR.EQ.LOWER)GO TO 24
21700 DO 14 I=2,10
21800 IF(NOWLTR.NE.IDIGIT(I))GO TO 14
21900 IFCASE=I-1
22000 KASATO=0
22100 GO TO 2
22200 14 CONTINUE
22300 GO TO 2
22400 15 NOWVRT=1
22500 NOWHRZ=1
22600 IFCASE=1
22700 KASATO=0
22800 LWIDE=KWIDE
22900 IWHITE=MOVE
23000 GO TO 2
23100 16 NOWVRT=-1
23200 GO TO 2
23300 17 NOWHRZ=-1
23400 GO TO 2
23500 18 IF(IWHITE.GT.0)IWHITE=0
23600 GO TO 2
23700 19 IF(IWHITE.EQ.0)IWHITE=1
23800 GO TO 2
23900 20 LWIDE=KWIDE/2
24000 GO TO 2
24100 21 LWIDE=(3*KWIDE)/2
24200 GO TO 2
24300 22 IF(KASATO.LT.0)IFCASE=-KASATO-IFCASE
24400 KASATO=0
24500 GO TO 2
24600 23 IF(KASATO.EQ.0)KASATO=(4*((IFCASE+1)/2))-1
24700 IF(KASATO.GT.0)GO TO 2
24800 KASATO=-KASATO
24900 IFCASE=KASATO-IFCASE
25000 GO TO 2
25100 24 IF(KASATO.LT.0)GO TO 2
25200 IF(KASATO.EQ.0)KASATO=(4*((IFCASE+1)/2))-1
25300 IFCASE=KASATO-IFCASE
25400 KASATO=-KASATO
25500 GO TO 2
25600 C
25700 C PREPARE TO PLOT CHARACTER
25800 25 MATCH=LSTKAS
25900 26 IF(KASATO.LE.0)GO TO 27
26000 IFCASE=KASATO-IFCASE
26100 KASATO=-KASATO
26200 27 NOWLNG=LENGTH(MATCH)
26300 C
26400 C DETERMINE OPTIMUM SPACING
26500 C
26600 C SKIP AROUND THIS CODE IF NORMAL
26700 C INTER-CHARACTER SPACING IS ACCEPTABLE
26800 C WITHOUT WHITE AREA ADJUSTMENT.
26900 C THE CALCULATIONS ARE DESIGNED TO PRODUCE
27000 C DISTANCES OF THE SORT
27100 C
27200 C 4
27300 C 34
27400 C 234
27500 C 1234
27600 C 01234
27700 C X01234
27800 C 01234
27900 C 1234
28000 C 234
28100 C 34
28200 C 4
28300 C
28400 C THE FIRST LOOP CATCHES THE MOST COMMON CASE OF
28500 C 2 CHARACTERS TOUCHING ON THE SAME LINE. THE
28600 C SECOND LONGER LOOP CATCHES THIS CASE AND ALL
28700 C OTHERS AND COULD BE USED BY ITSELF.
28800 IF(IWHITE.LT.0)GO TO 46
28900 IF(JSPACE.EQ.0)GO TO 47
29000 LSTTST=NOWTST
29100 NOWTST=2**(NOWLNG-1)
29200 IF(LAST.EQ.0)GO TO 47
29300 IF(IWHITE.EQ.0)GO TO 47
29400 MIN=JSPACE
29500 ISTART=IHIGH*(LAST-1)
29600 JSTART=IHIGH*(MATCH-1)
29700 IF(LSTVRT.EQ.NOWVRT)GO TO 28
29800 LSTVRT=-1
29900 ISTART=ISTART+IHIGH+1
30000 GO TO 29
30100 28 LSTVRT=1
30200 29 IINDEX=ISTART
30300 JINDEX=JSTART
30400 DO 33 I=1,IHIGH
30500 IINDEX=IINDEX+LSTVRT
30600 JINDEX=JINDEX+1
30700 K=IPACKD(IINDEX)
30800 IF(LSTHRZ.LT.0)GO TO 30
30900 IF(K.EQ.(2*(K/2)))GO TO 33
31000 GO TO 31
31100 30 IF(K.LT.LSTTST)GO TO 33
31200 31 K=IPACKD(JINDEX)
31300 IF(NOWHRZ.GT.0)GO TO 32
31400 IF(K.EQ.(2*(K/2)))GO TO 33
31500 GO TO 47
31600 32 IF(K.GE.NOWTST)GO TO 47
31700 33 CONTINUE
31800 DO 45 I=1,IHIGH
31900 ISTART=ISTART+LSTVRT
32000 K=IPACKD(ISTART)
32100 IF(K.EQ.0)GO TO 45
32200 IF(LSTHRZ.GT.0)GO TO 35
32300 IDIST=LSTLNG
32400 34 K=K/2
32500 IDIST=IDIST-1
32600 IF(K.NE.0)GO TO 34
32700 GO TO 37
32800 35 IDIST=0
32900 36 L=K/2
33000 IF((L+L).NE.K)GO TO 37
33100 K=L
33200 IDIST=IDIST+1
33300 GO TO 36
33400 37 N=JSTART
33500 DO 44 J=1,IHIGH
33600 N=N+1
33700 K=IPACKD(N)
33800 IF(K.EQ.0)GO TO 44
33900 IF(NOWHRZ.GT.0)GO TO 39
34000 JDIST=IDIST
34100 38 L=K/2
34200 IF((L+L).NE.K)GO TO 41
34300 K=L
34400 JDIST=JDIST+1
34500 GO TO 38
34600 39 JDIST=IDIST+NOWLNG
34700 40 K=K/2
34800 JDIST=JDIST-1
34900 IF(K.NE.0)GO TO 40
35000 41 IF(I.GT.J)GO TO 42
35100 IF(I.EQ.J)GO TO 43
35200 JDIST=JDIST+J-I-1
35300 GO TO 43
35400 42 JDIST=JDIST+I-J-1
35500 43 IF(MIN.LE.JDIST)GO TO 44
35600 IF(JDIST.LE.0)GO TO 47
35700 MIN=JDIST
35800 44 CONTINUE
35900 45 CONTINUE
36000 KSPACE=KSPACE-MIN
36100 GO TO 47
36200 C
36300 C ADJUST CENTERING OF NARROW CHARACTERS IF NEEDED
36400 46 IF(NOWLNG.GE.KWIDE)GO TO 47
36500 IF((IUSED+KSPACE+KWIDE).GT.MAXKNT)GO TO 57
36600 NEED=(KWIDE-NOWLNG)/2
36700 KSPACE=KSPACE+NEED
36800 NEED=KWIDE-NEED-NOWLNG
36900 C
37000 C CONSTRUCT LETTER
37100 47 IF((IUSED+KSPACE+NOWLNG).GT.MAXKNT)GO TO 57
37200 48 IF(KSPACE.LE.0)GO TO 49
37300 KSPACE=KSPACE-1
37400 IUSED=IUSED+1
37500 IBUFFR(IUSED)=IBLANK
37600 GO TO 48
37700 49 I=(IHIGH*(MATCH-1))+NOWLIN
37800 IF(NOWVRT.LT.0)I=(IHIGH*MATCH)-NOWLIN+1
37900 I=IPACKD(I)
38000 LIMIT=NOWLNG
38100 IF(NOWHRZ.LT.0)GO TO 53
38200 IUSED=IUSED+NOWLNG
38300 J=IUSED
38400 50 IF(LIMIT.LE.0)GO TO 56
38500 LIMIT=LIMIT-1
38600 K=I/2
38700 IF((K+K).EQ.I)GO TO 51
38800 IBUFFR(J)=NOWLTR
38900 GO TO 52
39000 51 IBUFFR(J)=IBLANK
39100 52 J=J-1
39200 I=K
39300 GO TO 50
39400 53 IF(LIMIT.LE.0)GO TO 56
39500 LIMIT=LIMIT-1
39600 IUSED=IUSED+1
39700 K=I/2
39800 IF((K+K).EQ.I)GO TO 54
39900 IBUFFR(IUSED)=NOWLTR
40000 GO TO 55
40100 54 IBUFFR(IUSED)=IBLANK
40200 55 I=K
40300 GO TO 53
40400 56 IF(NEED.LE.0)GO TO 1
40500 NEED=NEED-1
40600 IUSED=IUSED+1
40700 IBUFFR(IUSED)=IBLANK
40800 GO TO 56
40900 C
41000 C ALL LETTERS REPRESENTED, JUSTIFY AND FILL
41100 57 NEED=0
41200 IF(JSTIFY.GE.0)NEED=MAXKNT-IUSED
41300 IF(JSTIFY.EQ.0)NEED=NEED/2
41400 NEED=IUSED+NEED
41500 INIKNT=MAXUSD
41600 MAXUSD=NEED
41700 IF(IFILL.GT.0)MAXUSD=MAXKNT
41800 I=MAXUSD
41900 58 IF(I.LE.NEED)GO TO 59
42000 IBUFFR(I)=IBLANK
42100 I=I-1
42200 GO TO 58
42300 59 IF(IUSED.LE.INIKNT)GO TO 60
42400 IBUFFR(I)=IBUFFR(IUSED)
42500 I=I-1
42600 IUSED=IUSED-1
42700 GO TO 59
42800 60 IF(I.LE.INIKNT)GO TO 62
42900 IBUFFR(I)=IBLANK
43000 I=I-1
43100 GO TO 60
43200 C
43300 C RETURN TO CALLING PROGRAM
43400 61 MAXLIN=0
43500 62 RETURN
43600 C545790969953$
43700 END