Trailing-Edge
-
PDP-10 Archives
-
decuslib20-05
-
decus/20-0141/dafont.for
There are 2 other files named dafont.for in the archive. Click here to see a list.
C RENBR(DAFONT/BIT PACK CHARACTER SHAPES FOR DATEXT)
C
C DONALD BARTH, CHEMISTRY DEPT., HARVARD UNIVERSITY
C
C THE FIRST LINE IN THE INPUT DATA FILE WILL BE COPIED
C INTO THE OUTPUT FILE WITH AN INITIAL LETTER C BEING
C ADDED SO THAT IT BECOMES A FORTRAN COMMENT LINE.
C SUBSEQUENT LINES IN THE DATA FILE SHOULD CONSIST OF
C THE CHARACTER SHAPES CONSTRUCTED OF THE CHARACTERS
C WHICH THEY ARE TO REPRESENT. THE FIRST ROW OF
C CHARACTER SHAPES MUST BE OF THE MAXIMUM HEIGHT SINCE
C THE HEIGHT OF THE FIRST ROW IS ASSUMED TO DEFINE THE
C HEIGHT FOR ALL SUBSEQUENT ROWS. THE FINAL LINE OF
C THE INPUT FILE SHOULD CONTAIN THE WORD END.
C
DIMENSION IPACKD(2880),LENGTH(96),KNOWN(96),
1IBUFFR(2400),NAMLNG(6),NAMPAC(6),KEEP(80),
2IROUTN(6),KOMENT(80),LTRSTR(96),NAMLTR(6)
DOUBLE PRECISION NAMSRC,NAMOUT
C
DATA MAXHIH,MAXWID,MAXLNG,MAXPAC/30,60,96,2880/
DATA NAMLNG/1HJ,1HL,1HN,1HG,1HT,1HH/
DATA NAMPAC/1HJ,1HP,1HA,1HC,1HK,1HD/
DATA NAMLTR/1HJ,1HL,1HE,1HT,1HT,1HR/
C
C IBUFFR = ARRAY INTO WHICH ALL OF THE INPUT LINES
C WHICH COULD DEFINE THE CURRENT LETTER SHAPES
C ARE PLACED BEFORE SEARCHING THIS ARRAY TO
C DIVIDE IT UP INTO THE ACTUAL LETTER SHAPES.
C IPACKD = ARRAY IN WHICH ARE STORED THE BINARY PACKED
C REPRESENTATIONS OF FORMS OF LETTERS.
C IROUTN = ARRAY IN WHICH THE ROUTINE NAME TO BE
C WRITTEN AS OUTPUT IS STORED. IF THIS MERELY
C CONTAINS SPACES, THEN A BLOCK DATA ROUTINE
C IS WRITTEN. OTHERWISE A SUBROUTINE IS
C GENERATED.
C KEEP = BUFFER INTO WHICH EACH LINE IS FIRST READ
C TO DETERMINE IF IT IS PART OF SPECIFICATION
C OF THE CURRENT BATCH OF LETTERS.
C KNOWN = ARRAY IN WHICH ARE STORED THOSE LETTERS
C WHICH HAVE BEEN REPRESENTED.
C KOMENT = ARRAY IN WHICH IS STORED THE FIRST LINE
C OF THE INPUT FILE UNTIL THIS IS WRITTEN INTO
C THE OUTPUT FILE AS A FORTRAN COMMENT LINE.
C LENGTH = ARRAY USED TO STORE THE WIDTHS OF EACH OF
C THE CHARACTERS WHICH HAVE BEEN DEFINED.
C LTRSTR = ARRAY USED TO HOLD ALL DIFFERENT CHARACTERS
C BEING DEFINED BY CURRENT LINES AND USED TO
C DETECT END OF ONE GROUP AND START OF NEXT
C NAMLNG = ARRAY CONTAINING THE LETTERS OF THE NAME OF
C ONE OF THE ARRAYS WHICH MUST BE WRITTEN AS A
C FORTRAN DATA STATEMENT.
C NAMPAC = ARRAY CONTAINING THE LETTERS OF THE NAME OF
C ONE OF THE ARRAYS WHICH MUST BE WRITTEN AS A
C FORTRAN DATA STATEMENT.
C MAXHIH = MAXIMUM HEIGHT OF LETTERS.
C IBUFFR MUST BE DIMENSIONED MAXWID*MAXHIH
C MAXLNG = DIMENSION OF LENGTH AND KNOWN ARRAYS
C THIS IS MAXIMUM NUMBER OF CHARACTERS
C WHICH CAN BE REPRESENTED. LETTER ARRAY
C MUST BE DIMENSIONED AT LEAST 4*MAXLNG.
C MAXPAC = DIMENSION OF IPACKD ARRAY. IPACKD
C STORES BIT PACKED REPRESENTATION OF
C CHARACTERS, 1 LINE PER CHARACTER.
C MAXPAC SHOULD BE AT LEAST HEIGHT
C OF CHARACTER TIMES NUMBER OF CHARACTERS.
C MAXWID = NUMBER OF CHARACTERS READ FROM EACH LINE.
C IBUFFR MUST BE ABLE TO HOLD MAXHIH LINES
C
C IDSK = INPUT UNIT NUMBER
C JDSK = OUTPUT UNIT NUMBER
C
DATA IDSK,JDSK/1,20/
DATA IBLANK/1H /
DATA JEND,KEND,LEND/1HE,1HN,1HD/
C
C ASK USER FOR FILE NAMES AND OPEN FILES
TYPE 1
1 FORMAT(19H INPUT FILE NAME = ,$)
ACCEPT 2,NAMSRC
2 FORMAT(1A10)
OPEN(UNIT=IDSK,FILE=NAMSRC,ACCESS='SEQIN')
TYPE 3
3 FORMAT(20H OUTPUT FILE NAME = ,$)
ACCEPT 2,NAMOUT
OPEN(UNIT=JDSK,FILE=NAMOUT,ACCESS='SEQOUT')
C
C ASK IF ARE TO GENERATE BLOCK DATA OR SUBROUTINE
4 TYPE 5
5 FORMAT(40H SUBROUTINE NAME (NONE IF BLOCK DATA) = ,$)
ACCEPT 6,IROUTN
6 FORMAT(6A1)
C
C PREPARE TO READ IN FILE
KNTPAC=0
KNTLNG=0
IHIGH=0
ISTORE=0
IEOF=0
READ(IDSK,9)KOMENT
C
C READ IN NEXT LINE
7 KNTBFR=0
L=0
INIKNO=KNTLNG
KNTSTR=0
IF(ISTORE.GT.0)GO TO 12
8 READ(IDSK,9,END=11)KEEP
9 FORMAT(80A1)
DO 10 I=1,MAXWID
IF(KEEP(I).EQ.IBLANK)GO TO 10
IF(I.GT.58)GO TO 13
IF(KEEP(I).NE.JEND)GO TO 13
IF(KEEP(I+1).NE.KEND)GO TO 13
IF(KEEP(I+2).NE.LEND)GO TO 13
GO TO 11
10 CONTINUE
IF(KNTBFR.EQ.0)GO TO 8
IF(KNTLNG.EQ.0)GO TO 22
GO TO 13
C
C TEST FOR END OF CURRENT CHARACTER DEFINTIONS
11 IF(KNTBFR.EQ.0)GO TO 35
IF(KNTLNG.EQ.0)GO TO 22
IEOF=1
GO TO 17
12 ISTORE=0
13 INISTR=KNTSTR
DO 16 I=1,MAXWID
IF(KEEP(I).EQ.IBLANK)GO TO 16
IF(KNTSTR.EQ.0)GO TO 15
DO 14 J=1,KNTSTR
IF(KEEP(I).NE.LTRSTR(J))GO TO 14
IF(J.LE.INISTR)INISTR=0
GO TO 16
14 CONTINUE
15 KNTSTR=KNTSTR+1
LTRSTR(KNTSTR)=KEEP(I)
16 CONTINUE
IF(INISTR.EQ.0)GO TO 19
IF(INISTR.EQ.KNTSTR)GO TO 19
ISTORE=1
17 DO 18 I=1,MAXWID
KNTBFR=KNTBFR+1
18 IBUFFR(KNTBFR)=IBLANK
L=L+1
IF(L.LT.IHIGH)GO TO 17
GO TO 22
19 DO 20 I=1,MAXWID
KNTBFR=KNTBFR+1
20 IBUFFR(KNTBFR)=KEEP(I)
IF(KNTLNG.EQ.0)GO TO 21
L=L+1
IF(L.LT.IHIGH)GO TO 8
GO TO 22
21 IHIGH=IHIGH+1
IF(IHIGH.LT.MAXHIH)GO TO 8
C
C FIND HOW FAR NEXT CHARACTER EXTENDS TO RIGHT
22 IEND=0
23 KOMPAR=IBLANK
24 ISTART=IEND+1
25 IEND=IEND+1
I=IEND
26 IF(I.GT.MAXWID)GO TO 29
K=I
DO 27 J=1,IHIGH
IF(IBUFFR(K).EQ.IBLANK)GO TO 27
IF(KOMPAR.EQ.IBUFFR(K))GO TO 28
IF(KOMPAR.NE.IBLANK)GO TO 30
KOMPAR=IBUFFR(K)
GO TO 25
27 K=K+MAXWID
IF(KOMPAR.EQ.IBLANK)GO TO 24
I=I+1
GO TO 26
28 IEND=I
GO TO 25
29 IF(KOMPAR.NE.IBLANK)GO TO 30
IF(IEOF.EQ.0)GO TO 7
GO TO 35
C
C STORE THE NEW CHARACTER
30 IEND=IEND-1
I=INIKNO
31 I=I+1
IF(I.GT.KNTLNG)GO TO 32
IF(KOMPAR.NE.KNOWN(I))GO TO 31
GO TO 23
32 KNTLNG=KNTLNG+1
KNOWN(KNTLNG)=KOMPAR
LENGTH(KNTLNG)=IEND-ISTART+1
33 K=ISTART
ISTART=ISTART+1
I=KNTPAC
DO 34 J=1,IHIGH
I=I+1
IPACKD(I)=2*IPACKD(I)
IF(IBUFFR(K).NE.IBLANK)IPACKD(I)=IPACKD(I)+1
34 K=K+MAXWID
IF(ISTART.LE.IEND)GO TO 33
KNTPAC=KNTPAC+IHIGH
IF((KNTPAC+IHIGH).GT.MAXPAC)GO TO 35
IF(KNTLNG.LT.MAXLNG)GO TO 23
C
C ALL READ, FIND MOST COMMON WIDTH TO USE FOR BLANK
C J = TOTAL NUMBER OF CHARACTERS HAVING WIDTHS
C LESS THAN CURRENT TEST WIDTH
C K = NUMBER OF CHARACTER WIDTHS MATCHED FOR
C CURRENT VALUE OF IWIDE
C L = SUBSCRIPT IN MATCHING LOOP
C M = NUMBER OF CHARACTERS HAVING WIDTH EQUAL TO
C THE CURRENT TEST WIDTH
C IWIDE = TEST WIDTH FOR WHICH THERE HAS BEEN THE
C MOST MATCHES
C JWIDE = TEST WIDTH, LEFT WITH MAXIMUM WIDTH
35 JWIDE=0
J=0
K=0
36 JWIDE=JWIDE+1
IF(JWIDE.GT.MAXWID)GO TO 40
L=0
M=0
37 L=L+1
IF(L.GT.KNTLNG)GO TO 38
IF(LENGTH(L).EQ.JWIDE)M=M+1
GO TO 37
38 IF(K.GT.M)GO TO 39
K=M
IWIDE=JWIDE
39 J=J+M
IF(J.LT.KNTLNG)GO TO 36
C
C CREATE THE BLOCK DATA PROGRAM AS OUTPUT
40 IF(IROUTN(1).EQ.IBLANK)WRITE(JDSK,41)
41 FORMAT(6X,10HBLOCK DATA)
IF(IROUTN(1).NE.IBLANK)WRITE(JDSK,42)IROUTN
42 FORMAT(6X,11HSUBROUTINE ,6A1)
J=MAXWID
43 IF(KOMENT(J).NE.IBLANK)GO TO 44
J=J-1
IF(J.GT.1)GO TO 43
44 WRITE(JDSK,45),(KOMENT(I),I=1,J)
45 FORMAT(1HC,80A1)
I=KNTPAC
IF(I.LT.672)I=672
WRITE(JDSK,46)I
46 FORMAT(
16X,43HCOMMON/FASPG/KNTLTR,IHIGH,IWIDE,JWIDE,LOCK,/
25X,30H1LETTER(96),LENGTH(96),IPACKD(,1I4,1H))
C
C GENERATE THE DIMENSION STATEMENTS
CALL DASAVE(1,-1,53,10,LENGTH,
1KNTLNG,KNOWN,KNTLNG,NAMLTR,6,JDSK,IERR)
CALL DASAVE(1,1,53,10,LENGTH,
1KNTLNG,KNOWN,KNTLNG,NAMLNG,6,JDSK,IERR)
CALL DASAVE(1,1,53,10,IPACKD,
1KNTPAC,KNOWN,KNTLNG,NAMPAC,6,JDSK,IERR)
C
C GENERATE THE EQUIVALENCE STATEMENTS
WRITE(JDSK,47)
47 FORMAT(
16X,11HEQUIVALENCE,11X,22H(LETTER(1),JLETTR(1)),/
25X,44H1(LENGTH(1),JLNGTH(1)),(IPACKD(1),JPACKD(1)))
CALL DASAVE(2,-1,53,10,LENGTH,
1KNTLNG,KNOWN,KNTLNG,NAMLTR,6,JDSK,IERR)
CALL DASAVE(2,1,53,10,LENGTH,
1KNTLNG,KNOWN,KNTLNG,NAMLNG,6,JDSK,IERR)
CALL DASAVE(2,1,53,10,IPACKD,
1KNTPAC,KNOWN,KNTLNG,NAMPAC,6,JDSK,IERR)
C
C GENERATE THE DATA STATEMENTS
CALL DASAVE(3,-1,53,10,LENGTH,
1KNTLNG,KNOWN,KNTLNG,NAMLTR,6,JDSK,IERR)
CALL DASAVE(3,1,53,10,LENGTH,
1KNTLNG,KNOWN,KNTLNG,NAMLNG,6,JDSK,IERR)
CALL DASAVE(3,1,53,10,IPACKD,
1KNTPAC,KNOWN,KNTLNG,NAMPAC,6,JDSK,IERR)
WRITE(JDSK,48)KNTLNG,IHIGH,IWIDE,JWIDE
48 FORMAT(6X,35HDATA KNTLTR,IHIGH,IWIDE,JWIDE,LOCK/,
11I3,1H,1I2,1H,1I2,1H,1I2,5H,999/)
IF(IROUTN(1).NE.IBLANK)WRITE(JDSK,49)
49 FORMAT(6X,6HRETURN)
WRITE(JDSK,50)
50 FORMAT(6X,3HEND)
STOP
C574276657859$'
END