Trailing-Edge
-
PDP-10 Archives
-
decuslib10-08
-
43,50476/daturn.for
There are 2 other files named daturn.for in the archive. Click here to see a list.
SUBROUTINE DATURN(INTRVL,MOVE ,ISPACE,LTTR ,LTRBGN,
1 LTREND,LFTCOL,MAXBFR,IBUFFR,MAXUSD,MAGNFY,INISTR,
2 MAXSTR,KIND ,ISTORE)
C RENBR(/CONSTRUCT LARGE LETTERING TURNED 90 DEGREES)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C ROUTINE TO PRODUCE LARGE LETTERING EXTENDING ACROSS
C FANFOLDS. EACH CALL TO DATURN CONSTRUCTS A SINGLE
C LINE IN THE REPRESENTATION OF A SINGLE CHARACTER.
C DATURN SIGNALS TO THE CALLING PROGRAM WHEN THE FINAL
C CHARACTER HAS BEEN COMPLETELY REPRESENTATED. THIS
C ROUTINE MUST BE USED WITH A BLOCK DATA FONT CREATED
C BY THE PROGRAM DAFONT.
C
C INTRVL, MOVE, ISPACE, LTTR, LTRBGN, LTREND, LFTCOL,
C MAXBFR, MAGNFY, INISTR AND MAXSTR ARE USED ONLY FOR
C INPUT AND ARE RETURNED UNCHANGED. KIND AND ISTORE
C ARE USED BOTH FOR INPUT AND FOR RETURNING INFORMATION
C TO CALLING PROGRAM AND TO SUBSEQUENT CALLS TO THIS
C ROUTINE. IBUFFR AND MAXUSD ARE USED ONLY FOR OUTPUT.
C
C INTRVL = NUMBER OF BLANK LINES TO BE INSERTED BETWEEN
C 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 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 OR 0, REPRESENT INITIAL SPACES IN LTTR
C ARRAY. 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 LETTERING PRODUCED BY THIS
C ROUTINE IS LARGE, TERMINAL SPACES ARE
C IGNORED BUT BLANK LINES WILL BE GENERATED IF
C DATURN IS CALLED TO CONTINUE THE LETTERING
C REPRESENTATION ONCE ALL PRINTING CHARACTERS
C IN LTTR HAVE BEEN REPRESENTED.
C LTRBGN = SEQUENCE NUMBER WITHIN LTTR ARRAY OF FIRST
C LETTER TO BE REPRESENTED (THIS IS THE
C SUBSCRIPT OF LTTR ARRAY AT WHICH THE FIRST
C 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 LTTR ARRAY AT WHICH THE FINAL
C 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 MAXBFR = MAXIMUM SUBSCRIPT OF IBUFFR ARRAY LOCATION
C INTO WHICH CAN BE PLACED REPRESENTATION OF
C CONTENTS OF LTTR ARRAY.
C IBUFFR = ARRAY INTO WHICH IS TO BE PLACED THE
C REPRESENTATION OF LETTERS IN LTTR.
C MAXUSD = RETURNED BY DATURN CONTAINING NEW NUMBER OF
C LOCATIONS IN USE AFTER NEXT SECTION OF
C CHARACTER IN LTTR ARRAY HAS BEEN
C REPRESENTED.
C MAGNFY = INPUT CONTAINING MAGNIFICATION FACTOR WHICH
C IS APPLIED TO HEIGHT OF LETTERING. IF
C MAGNFY HAS VALUE 2, THEN EACH CHARACTER
C WHICH WOULD BE GENERATED TO FORM SHAPE IS
C REPEATED TWICE. SINCE FONTS ARE DESIGNED
C FOR 6 LINES PER INCH AND 10 CHARACTERS PER
C INCH FORMAT, LETTERING, WHEN TURNED 90
C DEGREES, WILL APPEAR EXTREMELY ELONGATED
C UNLESS HEIGHT IS MAGNIFIED. MAGNFY VALUE OF
C 3 WOULD PRODUCE APPROXIMATELY NORMALLY
C PROPORTIONED LETTERING. IF EACH LINE
C RETURNED BY DATURN IS PRINTED TWICE, THEN
C EXTREMELY LARGE LETTERING CAN BE PRODUCED BY
C SETTING MAGNFY TO 5. IT IS OF COURSE
C NECESSARY THAT IBUFFR ARRAY BE LARGE ENOUGH
C TO CONTAIN MAGNIFIED IMAGE OF LETTERING.
C INISTR = INPUT CONTAINING SUBSCRIPT OF FIRST LOCATION
C IN ISTORE ARRAY WHICH CAN BE USED TO
C TRANSFER INFORMATION ABOUT CURRENT STATE OF
C LETTERING PROCESS TO SUBSEQUENT CALL OF THIS
C ROUTINE WHICH IS TO CONTINUE REPRESENTATION
C OF SAME LINE OF TEXT.
C MAXSTR = INPUT CONTAINING SUBSCRIPT OF FINAL LOCATION
C IN ISTORE ARRAY WHICH CAN BE USED TO
C TRANSFER INFORMATION ABOUT CURRENT STATE OF
C LETTERING PROCESS TO SUBSEQUENT CALL OF THIS
C ROUTINE WHICH IS TO CONTINUE REPRESENTATION
C OF SAME LINE OF TEXT. AT LEAST 18 LOCATIONS
C IN ISTORE ARRAY ARE NEEDED FOR THIS PURPOSE,
C BUT IT IS REQUESTED THAT AT LEAST 24
C LOCATIONS BE RESERVED TO ALLOW FOR FUTURE
C ENHANCEMENT OF ROUTINE.
C KIND = MUST BE INPUT CONTAINING ZERO WHEN THIS
C ROUTINE IS FIRST CALLED TO REPRESENT
C PARTICULAR LINE OF TEXT. THEREAFTER, VALUE
C OF KIND RETURNED BY THIS ROUTINE SHOULD BE
C SUPPLIED TO SUBSEQUENT CALL WHICH IS
C CONTINUING REPRESENTATION OF SAME LINE OF
C TEXT. KIND IS RETURNED CONTAINING ONE OF
C FOLLOWING VALUES.
C = 1, RETURNED IF LINE OF TEXT HAS BEEN
C COMPLETELY REPRESENTED. IBUFFR(LFTCOL+1)
C THROUGH AND INCLUDING IBUFFR(MAXUSD) IS
C RETURNED CONTAINING SPACES. THIS PORTION OF
C IBUFFR ARRAY WILL AGAIN BE RETURNED
C CONTAINING SPACES IF DATURN IS SUBSEQUENTLY
C CALLED WITH VALUE OF KIND BEING UNCHANGED.
C = 2, RETURNED IF IBUFFR(LFTCOL+1) THROUGH AND
C INCLUDING IBUFFR(MAXUSD) IS RETURNED
C CONTAINING PORTION OF REPRESENTATION OF
C SINGLE CHARACTER.
C = 3, RETURNED IF AVAILABLE PORTION OF IBUFFR
C ARRAY WAS INSUFFICIENT TO CONTAIN
C REPRESENTATION OF LETTERING. MAXBFR-LFTCOL
C IS LESS THAN MAGNFY TIMES CHARACTER HEIGHT.
C = 4, RETURNED IF AVAILABLE PORTION OF ISTORE
C ARRAY WAS INSUFFICIENT TO CONTAIN
C DESCRIPTION OF CURRENT STATE OF LETTERING
C PROCESS FOR TRANSFER TO SUBSEQUENT CALL TO
C THIS ROUTINE WHICH IS TO CONTINUE LETTERING
C OF SAME LINE OF TEXT.
C = 5, RETURNED IF FONT WAS NOT LOADED.
C ISTORE = ARRAY USED TO TRANSFER DESCRIPTION OF
C CURRENT STATE OF LETTERING PROCESS TO
C SUBSEQUENT CALL OF THIS ROUTINE WHICH IS TO
C CONTINUE REPRESENTATION OF SAME LINE OF
C TEXT. THE ORIGINAL CONTENTS OF ISTORE ARRAY
C ARE IGNORED AND ARE DESTROYED.
C
COMMON/FASPG/KNTLTR,IHIGH,IWIDE,JWIDE,LOCK,
1LETTER(96),LENGTH(96),IPACKD(672)
C
DIMENSION LTTR(LTREND),IBUFFR(MAXBFR),ISTORE(MAXSTR),
1IDIGIT(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
MAXUSD=LFTCOL
IF(LOCK.NE.999)GO TO 56
IF((MAXSTR-INISTR).LT.17)GO TO 55
MULTPL=MAGNFY
IF(MULTPL.LE.0)MULTPL=1
IF((LFTCOL+(MULTPL*IHIGH)).GT.MAXBFR)GO TO 54
JSPACE=INTRVL
IF(JSPACE.LT.0)JSPACE=0
KWIDE=IWIDE
IF(MOVE.LE.-2)KWIDE=JWIDE
IF(KIND.GT.0)GO TO 44
KIND=2
LTRNXT=LTRBGN
IWHITE=MOVE
LAST=0
KSPACE=0
NEED=0
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+NEED
NEED=0
LAST=MATCH
LSTVRT=NOWVRT
LSTHRZ=NOWHRZ
LSTLNG=NOWLNG
2 LTRNXT=LTRNXT+1
3 IF(LTRNXT.GT.LTREND)GO TO 50
NOWLTR=LTTR(LTRNXT)
IF(NOWLTR.EQ.IBLANK)GO TO 7
IF(NOWLTR.EQ.KOMAND)GO TO 10
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 23
LSTKAS=MATCH
GO TO 5
6 IF(KNTKAS.GT.0)GO TO 22
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(IWHITE.LE.0)KSPACE=KSPACE+JSPACE
GO TO 2
C
C DOLLAR CONTROL CHARACTER FOUND
10 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 13
IF(NOWLTR.EQ.IHRZNT)GO TO 14
IF(NOWLTR.EQ.IEQUAL)GO TO 12
IF(NOWLTR.EQ.IFIXED)GO TO 15
IF(NOWLTR.EQ.IADJST)GO TO 16
IF(NOWLTR.EQ.NARROW)GO TO 17
IF(NOWLTR.EQ.NWIDE)GO TO 18
IF(NOWLTR.EQ.IEND)GO TO 19
IF(NOWLTR.EQ.IUPPER)GO TO 20
IF(NOWLTR.EQ.LOWER)GO TO 21
DO 11 I=2,10
IF(NOWLTR.NE.IDIGIT(I))GO TO 11
IFCASE=I-1
KASATO=0
GO TO 2
11 CONTINUE
GO TO 2
12 NOWVRT=1
NOWHRZ=1
IFCASE=1
KASATO=0
LWIDE=KWIDE
IWHITE=MOVE
GO TO 2
13 NOWVRT=-1
GO TO 2
14 NOWHRZ=-1
GO TO 2
15 IF(IWHITE.GT.0)IWHITE=0
GO TO 2
16 IF(IWHITE.EQ.0)IWHITE=1
GO TO 2
17 LWIDE=KWIDE/2
GO TO 2
18 LWIDE=(3*KWIDE)/2
GO TO 2
19 IF(KASATO.LT.0)IFCASE=-KASATO-IFCASE
KASATO=0
GO TO 2
20 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
21 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
22 MATCH=LSTKAS
23 IF(KASATO.LE.0)GO TO 24
IFCASE=KASATO-IFCASE
KASATO=-KASATO
24 NOWLNG=LENGTH(MATCH)
LSTTST=NOWTST
NOWTST=2**(NOWLNG-1)
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 43
IF(JSPACE.EQ.0)GO TO 45
IF(LAST.EQ.0)GO TO 45
IF(IWHITE.EQ.0)GO TO 45
MIN=JSPACE
ISTART=IHIGH*(LAST-1)
JSTART=IHIGH*(MATCH-1)
IF(LSTVRT.EQ.NOWVRT)GO TO 25
LSTVRT=-1
ISTART=ISTART+IHIGH+1
GO TO 26
25 LSTVRT=1
26 IINDEX=ISTART
JINDEX=JSTART
DO 30 I=1,IHIGH
IINDEX=IINDEX+LSTVRT
JINDEX=JINDEX+1
K=IPACKD(IINDEX)
IF(LSTHRZ.LT.0)GO TO 27
IF(K.EQ.(2*(K/2)))GO TO 30
GO TO 28
27 IF(K.LT.LSTTST)GO TO 30
28 K=IPACKD(JINDEX)
IF(NOWHRZ.GT.0)GO TO 29
IF(K.EQ.(2*(K/2)))GO TO 30
GO TO 45
29 IF(K.GE.NOWTST)GO TO 45
30 CONTINUE
DO 42 I=1,IHIGH
ISTART=ISTART+LSTVRT
K=IPACKD(ISTART)
IF(K.EQ.0)GO TO 42
IF(LSTHRZ.GT.0)GO TO 32
IDIST=LSTLNG
31 K=K/2
IDIST=IDIST-1
IF(K.NE.0)GO TO 31
GO TO 34
32 IDIST=0
33 L=K/2
IF((L+L).NE.K)GO TO 34
K=L
IDIST=IDIST+1
GO TO 33
34 N=JSTART
DO 41 J=1,IHIGH
N=N+1
K=IPACKD(N)
IF(K.EQ.0)GO TO 41
IF(NOWHRZ.GT.0)GO TO 36
JDIST=IDIST
35 L=K/2
IF((L+L).NE.K)GO TO 38
K=L
JDIST=JDIST+1
GO TO 35
36 JDIST=IDIST+NOWLNG
37 K=K/2
JDIST=JDIST-1
IF(K.NE.0)GO TO 37
38 IF(I.GT.J)GO TO 39
IF(I.EQ.J)GO TO 40
JDIST=JDIST+J-I-1
GO TO 40
39 JDIST=JDIST+I-J-1
40 IF(MIN.LE.JDIST)GO TO 41
IF(JDIST.LE.0)GO TO 45
MIN=JDIST
41 CONTINUE
42 CONTINUE
KSPACE=KSPACE-MIN
GO TO 45
C
C ADJUST CENTERING OF NARROW CHARACTERS IF NEEDED
43 IF(NOWLNG.GE.KWIDE)GO TO 45
NEED=(KWIDE-NOWLNG)/2
KSPACE=KSPACE+NEED
NEED=KWIDE-NEED-NOWLNG
GO TO 45
C
C SECOND OR SUBSEQUENT LINE
44 IF(KIND.NE.2)GO TO 50
IFCASE=ISTORE(INISTR)
IWHITE=ISTORE(INISTR+1)
KASATO=ISTORE(INISTR+2)
KSPACE=ISTORE(INISTR+3)
LAST =ISTORE(INISTR+4)
LSTHRZ=ISTORE(INISTR+5)
LSTKAS=ISTORE(INISTR+6)
LSTLNG=ISTORE(INISTR+7)
LSTTST=ISTORE(INISTR+8)
LSTVRT=ISTORE(INISTR+9)
LTRNXT=ISTORE(INISTR+10)
LWIDE =ISTORE(INISTR+11)
MATCH =ISTORE(INISTR+12)
NEED =ISTORE(INISTR+13)
NOWHRZ=ISTORE(INISTR+14)
NOWLNG=ISTORE(INISTR+15)
NOWTST=ISTORE(INISTR+16)
NOWVRT=ISTORE(INISTR+17)
IF(KSPACE.LE.0)GO TO 46
KSPACE=KSPACE-1
C
C CONSTRUCT LETTER
45 IF(KSPACE.GT.0)GO TO 51
LSTTST=1
IF(NOWHRZ.GT.0)LSTTST=NOWTST
LSTLNG=NOWLNG
46 IF(LSTLNG.LE.0)GO TO 1
INITAL=IHIGH*(MATCH-1)
IF(NOWVRT.GT.0)INITAL=INITAL+IHIGH+1
NOWLTR=LTTR(LTRNXT)
DO 48 I=1,IHIGH
INITAL=INITAL-NOWVRT
K=IPACKD(INITAL)/LSTTST
K=K-(2*(K/2))
DO 47 J=1,MULTPL
MAXUSD=MAXUSD+1
IBUFFR(MAXUSD)=IBLANK
IF(K.NE.0)IBUFFR(MAXUSD)=NOWLTR
47 CONTINUE
48 CONTINUE
LSTLNG=LSTLNG-1
IF(NOWHRZ.LT.0)GO TO 49
LSTTST=LSTTST/2
GO TO 53
49 LSTTST=2*LSTTST
GO TO 53
C
C CONSTRUCT LINE OF BLANKS
50 KIND=1
51 I=LFTCOL+(MULTPL*IHIGH)
52 MAXUSD=MAXUSD+1
IBUFFR(MAXUSD)=IBLANK
IF(MAXUSD.LT.I)GO TO 52
IF(KIND.NE.2)GO TO 57
C
C STORE VARIABLES NEEDED TO PRODUCE NEXT LINE
53 ISTORE(INISTR)=IFCASE
ISTORE(INISTR+1)=IWHITE
ISTORE(INISTR+2)=KASATO
ISTORE(INISTR+3)=KSPACE
ISTORE(INISTR+4)=LAST
ISTORE(INISTR+5)=LSTHRZ
ISTORE(INISTR+6)=LSTKAS
ISTORE(INISTR+7)=LSTLNG
ISTORE(INISTR+8)=LSTTST
ISTORE(INISTR+9)=LSTVRT
ISTORE(INISTR+10)=LTRNXT
ISTORE(INISTR+11)=LWIDE
ISTORE(INISTR+12)=MATCH
ISTORE(INISTR+13)=NEED
ISTORE(INISTR+14)=NOWHRZ
ISTORE(INISTR+15)=NOWLNG
ISTORE(INISTR+16)=NOWTST
ISTORE(INISTR+17)=NOWVRT
GO TO 57
C
C RETURN TO CALLING PROGRAM
54 KIND=3
GO TO 57
55 KIND=4
GO TO 57
56 KIND=5
57 RETURN
C736047020160$
END