Google
 

Trailing-Edge - PDP-10 Archives - decus_20tap5_198111 - 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