Trailing-Edge
-
PDP-10 Archives
-
decuslib10-11
-
43,50542/font.for
There is 1 other file named font.for in the archive. Click here to see a list.
C RENBR(FONT/BIT PACK CHARACTER SHAPES FOR FROFF)
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. A LINE CONTAINING
C WORD END SHOULD APPEAR BETWEEN SUBSEQUENT FONTS. THE
C THE FINAL LINE OF THE INPUT FILE SHOULD CONTAIN THE
C WORD END.
C
DIMENSION IPACKD(2880),LENGTH(480),LTRKNO(480),
1LTRBFR(2400),LTRLNG(6),LTRPAC(6),LTRINP(80),
2LTRSUB(6),LTRCOM(80),LTRSTR(96),LTRLET(6),LTRNXT(4),
3LWRNXT(4),LTREND(3),LWREND(3),MSTWID(10),MAXWID(10),
4LOCEND(10),ITALL(10),LTRHIH(6),LTRLMT(6),LTRMAX(6),
5LTRMNY(6)
DOUBLE PRECISION NAMSRC,NAMOUT
C
DATA MAXHIH,LMTWID,MAXLNG,MAXPAC,LMTFNT/30,60,480,2880,10/
DATA LTRLNG/1HI,1HC,1HL,1HM,1HN,1HS/
DATA LTRPAC/1HI,1HP,1HA,1HC,1HK,1HD/
DATA LTRLET/1HL,1HT,1HR,1HF,1HN,1HT/
DATA LTRHIH/1HI,1HL,1HI,1HN,1HE,1HS/
DATA LTRLMT/1HI,1HL,1HI,1HM,1HI,1HT/
DATA LTRMAX/1HI,1HM,1HA,1HX,1HM,1HM/
DATA LTRMNY/1HI,1HC,1HO,1HM,1HM,1HN/
C
C LTRBFR = 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 LTRSUB = 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 LTRINP = 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 LTRKNO = ARRAY IN WHICH ARE STORED THOSE LETTERS
C WHICH HAVE BEEN REPRESENTED.
C LTRCOM = 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 LTRLNG = ARRAY CONTAINING THE LETTERS OF THE NAME OF
C ONE OF THE ARRAYS WHICH MUST BE WRITTEN AS A
C FORTRAN DATA STATEMENT.
C LTRPAC = 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 LTRBFR MUST BE DIMENSIONED LMTWID*MAXHIH
C MAXLNG = DIMENSION OF LENGTH AND LTRKNO 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 LMTWID = NUMBER OF CHARACTERS READ FROM EACH LINE.
C LTRBFR 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 LTRSPA/1H /
DATA LTRNXT/1HN,1HE,1HX,1HT/
DATA LWRNXT/1Hn,1He,1Hx,1Ht/
DATA LTREND/1HE,1HN,1HD/
DATA LWREND/1He,1Hn,1Hd/
C
C TELL USER WHAT PROGRAM THIS IS
TYPE 1
1 FORMAT(' FONT'/
1' BIT CODES MULTILINE LETTERING FOR CONSTRUCTION BY FROFF')
C
C ASK USER FOR FILE NAMES AND OPEN FILES
TYPE 2
2 FORMAT(19H INPUT FILE NAME = ,$)
ACCEPT 3,NAMSRC
3 FORMAT(1A10)
OPEN(UNIT=IDSK,FILE=NAMSRC,ACCESS='SEQIN')
TYPE 4
4 FORMAT(20H OUTPUT FILE NAME = ,$)
ACCEPT 3,NAMOUT
OPEN(UNIT=JDSK,FILE=NAMOUT,ACCESS='SEQOUT')
C
C ASK IF ARE TO GENERATE BLOCK DATA OR SUBROUTINE
5 TYPE 6
6 FORMAT(40H SUBROUTINE NAME (NONE IF BLOCK DATA) = ,$)
ACCEPT 7,LTRSUB
7 FORMAT(6A1)
C
C PREPARE FOR FIRST FONT
READ(IDSK,11)LTRCOM
KNTFNT=0
KNTLNG=0
KNTPAC=0
8 KNTFNT=KNTFNT+1
C
C PREPARE TO READ IN FILE
INITAL=KNTLNG
IHIGH=0
ISTORE=0
IEOF=0
C
C READ IN NEXT LINE
9 KNTBFR=0
L=0
INIKNO=KNTLNG
KNTSTR=0
IF(ISTORE.GT.0)GO TO 25
10 READ(IDSK,11,END=23)LTRINP
11 FORMAT(80A1)
INIPRT=0
12 INIPRT=INIPRT+1
IF(INIPRT.GT.LMTWID)GO TO 13
IF(LTRINP(INIPRT).EQ.LTRSPA)GO TO 12
13 MAXPRT=LMTWID+1
14 MAXPRT=MAXPRT-1
IF(MAXPRT.LT.INIPRT)GO TO 21
IF(LTRINP(MAXPRT).EQ.LTRSPA)GO TO 14
J=INIPRT
DO 16 I=1,4
IF(J.GT.MAXPRT)GO TO 17
IF(LTRINP(J).EQ.LTRNXT(I))GO TO 15
IF(LTRINP(J).EQ.LWRNXT(I))GO TO 15
GO TO 17
15 J=J+1
16 CONTINUE
IF(J.LE.MAXPRT)GO TO 17
GO TO 22
17 J=INIPRT
DO 19 I=1,3
IF(J.GT.MAXPRT)GO TO 20
IF(LTRINP(J).EQ.LTREND(I))GO TO 18
IF(LTRINP(J).EQ.LWREND(I))GO TO 18
GO TO 20
18 J=J+1
19 CONTINUE
IF(J.LE.MAXPRT)GO TO 20
GO TO 23
20 GO TO 26
21 IF(KNTBFR.EQ.0)GO TO 10
IF(KNTLNG.EQ.INITAL)GO TO 35
GO TO 26
C
C TEST FOR END OF CURRENT CHARACTER DEFINTIONS
22 IEOF=-1
GO TO 24
23 IEOF=1
24 IF(KNTBFR.EQ.0)GO TO 48
IF(KNTLNG.EQ.INITAL)GO TO 35
GO TO 30
25 ISTORE=0
26 INISTR=KNTSTR
DO 29 I=1,LMTWID
IF(LTRINP(I).EQ.LTRSPA)GO TO 29
IF(KNTSTR.EQ.0)GO TO 28
DO 27 J=1,KNTSTR
IF(LTRINP(I).NE.LTRSTR(J))GO TO 27
IF(J.LE.INISTR)INISTR=0
GO TO 29
27 CONTINUE
28 KNTSTR=KNTSTR+1
LTRSTR(KNTSTR)=LTRINP(I)
29 CONTINUE
IF(INISTR.EQ.0)GO TO 32
IF(INISTR.EQ.KNTSTR)GO TO 32
ISTORE=1
30 DO 31 I=1,LMTWID
KNTBFR=KNTBFR+1
31 LTRBFR(KNTBFR)=LTRSPA
L=L+1
IF(L.LT.IHIGH)GO TO 30
GO TO 35
32 DO 33 I=1,LMTWID
KNTBFR=KNTBFR+1
33 LTRBFR(KNTBFR)=LTRINP(I)
IF(KNTLNG.EQ.INITAL)GO TO 34
L=L+1
IF(L.LT.IHIGH)GO TO 10
GO TO 35
34 IHIGH=IHIGH+1
IF(IHIGH.LT.MAXHIH)GO TO 10
C
C FIND HOW FAR NEXT CHARACTER EXTENDS TO RIGHT
35 IEND=0
36 LTRCMP=LTRSPA
37 ISTART=IEND+1
38 IEND=IEND+1
I=IEND
39 IF(I.GT.LMTWID)GO TO 42
K=I
DO 40 J=1,IHIGH
IF(LTRBFR(K).EQ.LTRSPA)GO TO 40
IF(LTRCMP.EQ.LTRBFR(K))GO TO 41
IF(LTRCMP.NE.LTRSPA)GO TO 43
LTRCMP=LTRBFR(K)
GO TO 38
40 K=K+LMTWID
IF(LTRCMP.EQ.LTRSPA)GO TO 37
I=I+1
GO TO 39
41 IEND=I
GO TO 38
42 IF(LTRCMP.NE.LTRSPA)GO TO 43
IF(IEOF.EQ.0)GO TO 9
GO TO 48
C
C STORE THE NEW CHARACTER
43 IEND=IEND-1
I=INIKNO
44 I=I+1
IF(I.GT.KNTLNG)GO TO 45
IF(LTRCMP.NE.LTRKNO(I))GO TO 44
GO TO 36
45 KNTLNG=KNTLNG+1
LTRKNO(KNTLNG)=LTRCMP
LENGTH(KNTLNG)=IEND-ISTART+1
46 K=ISTART
ISTART=ISTART+1
I=KNTPAC
DO 47 J=1,IHIGH
I=I+1
IPACKD(I)=2*IPACKD(I)
IF(LTRBFR(K).NE.LTRSPA)IPACKD(I)=IPACKD(I)+1
47 K=K+LMTWID
IF(ISTART.LE.IEND)GO TO 46
KNTPAC=KNTPAC+IHIGH
IF((KNTPAC+IHIGH).GT.MAXPAC)GO TO 48
IF(KNTLNG.LT.MAXLNG)GO TO 36
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
48 JWIDE=0
J=INITAL
K=0
49 JWIDE=JWIDE+1
IF(JWIDE.GT.LMTWID)GO TO 53
L=INITAL
M=0
50 L=L+1
IF(L.GT.KNTLNG)GO TO 51
IF(LENGTH(L).EQ.JWIDE)M=M+1
GO TO 50
51 IF(K.GT.M)GO TO 52
K=M
IWIDE=JWIDE
52 J=J+M
IF(J.LT.KNTLNG)GO TO 49
C
C CREATE THE BLOCK DATA PROGRAM AS OUTPUT
53 MAXWID(KNTFNT)=JWIDE
MSTWID(KNTFNT)=IWIDE
LOCEND(KNTFNT)=KNTLNG
ITALL(KNTFNT)=IHIGH
IF(KNTFNT.GE.LMTFNT)GO TO 54
IF(IEOF.LT.0)GO TO 8
54 IF(LTRSUB(1).EQ.LTRSPA)WRITE(JDSK,55)
55 FORMAT(6X,10HBLOCK DATA)
IF(LTRSUB(1).NE.LTRSPA)WRITE(JDSK,56)LTRSUB
56 FORMAT(6X,11HSUBROUTINE ,6A1)
J=LMTWID
57 IF(LTRCOM(J).NE.LTRSPA)GO TO 58
J=J-1
IF(J.GT.1)GO TO 57
58 WRITE(JDSK,59),(LTRCOM(I),I=1,J)
59 FORMAT(1HC,80A1)
I=KNTPAC
IF(I.LT.672)I=672
WRITE(JDSK,60)KNTLNG
60 FORMAT(
1' COMMON/RNOTWE/LTRFNT(',I4,')')
WRITE(JDSK,61)KNTLNG,
1KNTFNT,KNTFNT,KNTFNT,KNTFNT,KNTPAC
61 FORMAT(
1' COMMON/RNOTHI/LOCKED,KNTFNT,ICLMNS(',1I4,'),'/
2' 1ILIMIT(',1I4,'),ILINES(',1I4,'),IMAXMM(',1I4,'),'/
3' 2ICOMMN(',1I4,'),IPACKD(',1I4,')')
C
C GENERATE THE DIMENSION STATEMENTS
CALL DASAVE(-2,-1,53,10,LENGTH,
1KNTLNG,LTRKNO,KNTLNG,LTRLET,6,JDSK,IERR)
CALL DASAVE(-2,0,53,10,ITALL ,
1KNTFNT,LTRKNO,KNTLNG,LTRHIH,6,JDSK,IERR)
CALL DASAVE(-2,0,53,10,LOCEND,
1KNTFNT,LTRKNO,KNTLNG,LTRLMT,6,JDSK,IERR)
CALL DASAVE(-2,0,53,10,MAXWID,
1KNTFNT,LTRKNO,KNTLNG,LTRMAX,6,JDSK,IERR)
CALL DASAVE(-2,0,53,10,MSTWID,
1KNTFNT,LTRKNO,KNTLNG,LTRMNY,6,JDSK,IERR)
CALL DASAVE(-2,0,53,10,LENGTH,
1KNTLNG,LTRKNO,KNTLNG,LTRLNG,6,JDSK,IERR)
CALL DASAVE(-2,0,53,10,IPACKD,
1KNTPAC,LTRKNO,KNTLNG,LTRPAC,6,JDSK,IERR)
C
C GENERATE THE EQUIVALENCE STATEMENTS
CALL DASAVE(2,-1,53,10,LENGTH,
1KNTLNG,LTRKNO,KNTLNG,LTRLET,6,JDSK,IERR)
CALL DASAVE(2,0,53,10,ITALL ,
1KNTFNT,LTRKNO,KNTLNG,LTRHIH,6,JDSK,IERR)
CALL DASAVE(2,0,53,10,LOCEND,
1KNTFNT,LTRKNO,KNTLNG,LTRLMT,6,JDSK,IERR)
CALL DASAVE(2,0,53,10,MAXWID,
1KNTFNT,LTRKNO,KNTLNG,LTRMAX,6,JDSK,IERR)
CALL DASAVE(2,0,53,10,MSTWID,
1KNTFNT,LTRKNO,KNTLNG,LTRMNY,6,JDSK,IERR)
CALL DASAVE(2,0,53,10,LENGTH,
1KNTLNG,LTRKNO,KNTLNG,LTRLNG,6,JDSK,IERR)
CALL DASAVE(2,0,53,10,IPACKD,
1KNTPAC,LTRKNO,KNTLNG,LTRPAC,6,JDSK,IERR)
C
C GENERATE THE DATA STATEMENTS
CALL DASAVE(3,-1,53,10,LENGTH,
1KNTLNG,LTRKNO,KNTLNG,LTRLET,6,JDSK,IERR)
CALL DASAVE(3,0,53,10,ITALL ,
1KNTFNT,LTRKNO,KNTLNG,LTRHIH,6,JDSK,IERR)
CALL DASAVE(3,0,53,10,LOCEND,
1KNTFNT,LTRKNO,KNTLNG,LTRLMT,6,JDSK,IERR)
CALL DASAVE(3,0,53,10,MAXWID,
1KNTFNT,LTRKNO,KNTLNG,LTRMAX,6,JDSK,IERR)
CALL DASAVE(3,0,53,10,MSTWID,
1KNTFNT,LTRKNO,KNTLNG,LTRMNY,6,JDSK,IERR)
CALL DASAVE(3,0,53,10,LENGTH,
1KNTLNG,LTRKNO,KNTLNG,LTRLNG,6,JDSK,IERR)
CALL DASAVE(3,0,53,10,IPACKD,
1KNTPAC,LTRKNO,KNTLNG,LTRPAC,6,JDSK,IERR)
WRITE(JDSK,62)KNTFNT
62 FORMAT(6X,19HDATA KNTFNT,LOCKED/,
11I3,5H,999/)
IF(LTRSUB(1).NE.LTRSPA)WRITE(JDSK,63)
63 FORMAT(6X,6HRETURN)
WRITE(JDSK,64)
64 FORMAT(6X,3HEND)
STOP
END
SUBROUTINE DASAVE(IPART ,IFORMT,MAXCLM,MAXLIN,IDATA ,
1 KNTDAT,LETTER,KNTLTR,NAME ,KNTNAM,IOUT ,IERR )
C RENBR(/INTEGER AND 1H DATA STATEMENT GENERATOR)
C
C DONALD BARTH, CHEM. DEPT., HARVARD UNIVERSITY
C JUL 14, 1970
C
C IPART = -1, CONSTRUCT DIMENSION AND EQUIVALENCE
C STATEMENTS BUT NOT DATA STATEMENTS
C = 0, CONSTRUCT DIMENSION, EQUIVALENCE AND DATA
C STATEMENTS
C = 1, CONSTRUCT DIMENSION STATEMENTS ONLY
C = 2, CONSTRUCT EQUIVALENCE STATEMENTS ONLY
C = 3, CONSTRUCT DATA STATEMENTS ONLY
C = -4, -3 OR -2, IDENTICAL TO IPART=-1, 0 OR 1
C RESPECTIVELY, EXCEPT THAT DIMENSION
C STATEMENTS SPECIFY COMPONENT ARRAYS NECESARY
C TO CONSTRUCT ORGINAL ARRAY BUT DO NOT
C INCLUDE NAME AND DIMENSION OF ORIGINAL
C ARRAY.
C IFORMT = -1, REPRESENT CHARACTERS IN LETTER ARRAY
C WHICH WERE DEFINED BY 1H FIELDS OR READ WITH
C A1 FORMATS
C = 0, REPRESENT INTEGERS IN IDATA ARRAY IN
C COMPACT FORM
C = 1 OR GREATER, REPRESENT INTEGERS IN IDATA
C ARRAY IN COLUMNS WHICH ARE AT LEAST IFORMT
C CHARACTERS WIDE (IFORMT=10 IS EQUIVALENT TO
C I10 FORMAT)
C MAXCLM = NUMBER OF CHARACTERS TO BE IN STATEMENT
C FIELD (66 IF MAXIMUM, IE 72 MINUS LEFT 6
C COLUMNS)
C MAXLIN = MAXIMUM NUMBER OF LINES FOR SINGLE STATEMENT
C IDATA = ARRAY OF INTEGERS TO BE REPRESENTED IN DATA
C STATEMENTS IF IFORMT IS ZERO OR GREATER
C KNTDAT = NUMBER OF LOCATIONS IN IDATA ARRAY TO BE
C REPRESENTED IN DATA STATEMENTS
C LETTER = ARRAY OF CHARACTERS READ WITH A1 FORMAT OR
C DEFINED USING 1H FIELDS TO BE REPRESENTED IN
C DATA STATEMENTS IF IFORMT HAS VALUE -1
C KNTLTR = NUMBER OF LOCATIONS IN LETTER ARRAY TO BE
C REPRESENTED IN DATA STATEMENTS
C NAME = ALPHAMERIC ARRAY CONTAINING NAME OF ARRAY
C (READ BY MULTIPLE OF A1 FORMAT)
C KNTNAM = NUMBER OF LETTERS IN NAME OF ARRAY
C IOUT = OUTPUT UNIT ON WHICH STATEMENT IS WRITTEN
C IERR = 0 RETURNED IF COULD GENERATE DATA STATEMENT
C = 1 RETURNED IF MAXCLM TOO SMALL
C = 2 RETURNED IF ISTORE ARRAY TOO SMALL
C
DIMENSION IDATA(KNTDAT),LETTER(KNTLTR),NAME(KNTNAM),
1IBUFFR(66),ISTORE(200)
DATA IBLANK,ISLASH,KOMMA,ILPR,IRPR,IONE,IHOLLR/
11H ,1H/,1H,,1H(,1H),1H1,1HH/
C
C JSTORE = DIMENSION OF ISTORE ARRAY. THIS IS THE
C MAXIMUM NUMBER OF SMALL ARRAYS WHICH CAN
C BE USED TO REPRESENT THE IDATA ARRAY.
C
DATA JSTORE/200/
C
JPART=IPART
IF(JPART.LT.-1)JPART=JPART+3
IERR=0
IF(IFORMT)1,2,2
1 NEEDED=KNTLTR
GO TO 3
2 NEEDED=KNTDAT
3 IF(NEEDED)113,113,4
4 LOCK=1
MOST=0
MAX1=MAXCLM-1
MAX2=MAXCLM-2
LEFT=0
CALL DANUMB(0,NEEDED,10,IBUFFR,LEFT,0,MAXCLM)
LENGTH=KNTNAM+LEFT
IF(LENGTH-6)6,6,5
5 LENGTH=6
6 IF(IFORMT)12,81,7
C
C PREPARE FOR EXPANDED FORMAT
7 MOST=IDATA(1)
LEAST=MOST
DO 8 INDEX=1,NEEDED
IF(LEAST.GT.IDATA(INDEX))LEAST=IDATA(INDEX)
IF(MOST.LT.IDATA(INDEX))MOST=IDATA(INDEX)
8 CONTINUE
KOUNT=0
CALL DANUMB(0,MOST,10,IBUFFR,KOUNT,0,MAXCLM)
MOST=KOUNT
KOUNT=0
CALL DANUMB(0,LEAST,10,IBUFFR,KOUNT,0,MAXCLM)
IF(MOST-KOUNT)9,10,10
9 MOST=KOUNT
10 IF(MOST-IFORMT)11,13,13
11 MOST=IFORMT
GO TO 13
12 MOST=3
13 LIMIT=MAXLIN*((MAXCLM-LENGTH-6)/(MOST+1))
IF(LIMIT)112,112,14
14 KNTPRT=1+((NEEDED-1)/LIMIT)
IF(KNTPRT-JSTORE)15,15,111
15 LEAST=1
DO 16 INDEX=1,KNTPRT
ISTORE(INDEX)=LEAST
16 LEAST=LEAST+LIMIT
C
C TEST IF LABELS ARE OF MINIMUM LENGTH
17 ITEST=0
CALL DANUMB(0,ISTORE(KNTPRT),10,IBUFFR,ITEST,0,
1MAXCLM)
IF(KNTNAM+ITEST-LENGTH)18,19,19
18 LENGTH=KNTNAM+ITEST
IF(IFORMT)13,81,13
19 LOCK=0
IF(IFORMT)21,20,21
20 LEFT=0
ITEST=0
C
C CONSTRUCT SINGLE LINE OF DIMENSION STATEMENT
21 IF(JPART-2)22,59,81
22 INDEX=0
DO 23 LEAST=1,10
23 IBUFFR(LEAST)=IBLANK
24 LINE=1
LAST=INDEX
25 KOUNT=10
26 IF(INDEX)27,27,39
C
C INSERT NAME OF MAIN ARRAY
27 IF(IFORMT)28,29,28
28 LIMIT=-LENGTH
GO TO 30
29 LIMIT=0
30 LEAST=KOUNT
CALL DABOTH(LIMIT,LEFT,NAME,KNTNAM,0,NEEDED,IBUFFR,
1KOUNT,MAX1)
C
C OUTPUT COMMENT LINE DESCRIBING DIMENSION
IF(IPART+1)31,38,38
31 IF(LINE-1)32,32,35
32 IF(KOUNT-10)33,33,34
33 WRITE(IOUT,120)
GO TO 52
34 WRITE(IOUT,120)(IBUFFR(LEAST),LEAST=11,KOUNT)
GO TO 37
35 IF(KOUNT-LEAST)112,112,36
36 WRITE(IOUT,121)MANY,(IBUFFR(LEAST),LEAST=1,KOUNT)
37 INDEX=1
GO TO 24
C
C INSERT NAME OF SMALL ARRAY
38 IF(KOUNT-LEAST)46,46,43
39 IF(INDEX-KNTPRT)41,40,40
40 LIMIT=NEEDED-ISTORE(INDEX)+1
GO TO 42
41 LIMIT=ISTORE(INDEX+1)-ISTORE(INDEX)
42 LEAST=KOUNT
CALL DABOTH(LENGTH,LEFT,NAME,KNTNAM,ISTORE(INDEX),
1LIMIT,IBUFFR,KOUNT,MAX1)
IF(KOUNT-LEAST)44,44,43
43 INDEX=INDEX+1
KOUNT=KOUNT+1
IBUFFR(KOUNT)=KOMMA
IF(INDEX-KNTPRT)26,26,45
C
C OUTPUT SINGLE LINE OF DIMENSION STATEMENT
44 IF(LINE-MAXLIN)46,45,45
45 KOUNT=KOUNT-1
46 IF(LINE-1)47,47,50
47 IF(KOUNT-10)48,48,49
48 WRITE(IOUT,116)
GO TO 52
49 WRITE(IOUT,116)(IBUFFR(LEAST),LEAST=11,KOUNT)
GO TO 52
50 IF(KOUNT)112,112,51
51 WRITE(IOUT,119)MANY,(IBUFFR(LEAST),LEAST=1,KOUNT)
MANY=MANY+1
IF(MANY-9)53,53,52
52 MANY=1
53 IF(INDEX-KNTPRT)54,54,58
54 IF(LINE-MAXLIN)56,55,55
55 IF(INDEX-LAST)112,112,24
56 LINE=LINE+1
IF(IFORMT)25,57,25
57 KOUNT=0
GO TO 26
C
C CONSTRUCT SINGLE LINE OF EQUIVALENCE STATEMENT
58 IF(JPART)59,59,113
59 INDEX=1
DO 60 LEAST=1,12
60 IBUFFR(LEAST)=IBLANK
61 LINE=1
LAST=INDEX
62 KOUNT=12
C
C INSERT NAME OF SMALL ARRAY
63 KOUNT=KOUNT+1
LEAST=KOUNT
CALL DABOTH(LENGTH,0,NAME,KNTNAM,ISTORE(INDEX),1,
1IBUFFR,KOUNT,MAX2)
IF(KOUNT-LEAST)66,66,64
C
C INSERT NAME OF MAIN ARRAY
64 KOUNT=KOUNT+1
LIMIT=KOUNT
CALL DABOTH(0,ITEST,NAME,KNTNAM,0,ISTORE(INDEX),
1IBUFFR,KOUNT,MAX2)
IF(KOUNT-LIMIT)66,66,65
65 IBUFFR(LEAST)=ILPR
IBUFFR(LIMIT)=KOMMA
KOUNT=KOUNT+1
IBUFFR(KOUNT)=IRPR
KOUNT=KOUNT+1
IBUFFR(KOUNT)=KOMMA
INDEX=INDEX+1
IF(INDEX-KNTPRT)63,63,67
C
C OUTPUT SINGLE LINE OF EQUIVALENCE STATEMENT
66 KOUNT=LEAST-1
IF(LINE-MAXLIN)68,67,67
67 KOUNT=KOUNT-1
68 IF(LINE-1)69,69,72
69 IF(KOUNT-12)70,70,71
70 WRITE(IOUT,117)
GO TO 74
71 WRITE(IOUT,117)(IBUFFR(LEAST),LEAST=13,KOUNT)
GO TO 74
72 IF(KOUNT)112,112,73
73 WRITE(IOUT,119)MANY,(IBUFFR(LEAST),LEAST=1,KOUNT)
MANY=MANY+1
IF(MANY-9)75,75,74
74 MANY=1
75 IF(INDEX-KNTPRT)76,76,80
76 IF(LINE-MAXLIN)78,77,77
77 IF(INDEX-LAST)112,112,61
78 LINE=LINE+1
IF(IFORMT)62,79,62
79 KOUNT=0
GO TO 63
C
C CONSTRUCT SINGLE LINE OF DATA STATEMENT
80 IF(JPART)113,81,113
81 INDEX=1
KNTPRT=0
82 LINE=1
LAST=INDEX+1
KOUNT=5
83 LIMIT=KOUNT+MOST
84 LEAST=KOUNT
IF(LAST-INDEX)88,88,85
C
C INSERT NAME OF SMALL ARRAY
85 CALL DABOTH(LENGTH,-1,NAME,KNTNAM,INDEX,0,IBUFFR,
1KOUNT,MAX1)
IF(KOUNT-LEAST)97,97,86
86 LAST=INDEX
KOUNT=KOUNT+1
IBUFFR(KOUNT)=ISLASH
IF(KNTPRT-JSTORE)87,111,111
87 KNTPRT=KNTPRT+1
ISTORE(KNTPRT)=INDEX
GO TO 83
C
C INSERT INTEGER ENTRY
88 IF(IFORMT)90,89,89
89 CALL DANUMB(IFORMT,IDATA(INDEX),10,IBUFFR,KOUNT,
1LIMIT,MAX1)
IF(KOUNT-LEAST)95,95,94
GO TO 94
90 IF(LIMIT-MAX1)91,91,95
91 IF(KOUNT-(LIMIT-3))92,93,93
92 KOUNT=KOUNT+1
IBUFFR(KOUNT)=IBLANK
GO TO 91
93 KOUNT=KOUNT+3
IBUFFR(KOUNT-2)=IONE
IBUFFR(KOUNT-1)=IHOLLR
IBUFFR(KOUNT)=LETTER(INDEX)
94 KOUNT=KOUNT+1
IBUFFR(KOUNT)=KOMMA
INDEX=INDEX+1
IF(INDEX-NEEDED)83,83,96
C
C OUTPUT SINGLE LINE OF DATA STATEMENT
95 IF(LINE-MAXLIN)97,96,96
96 IBUFFR(KOUNT)=ISLASH
97 IF(LOCK)98,98,105
98 IF(LINE-1)99,99,102
99 IF(KOUNT-5)100,100,101
100 WRITE(IOUT,118)
GO TO 104
101 WRITE(IOUT,118)(IBUFFR(LEAST),LEAST=6,KOUNT)
GO TO 104
102 IF(KOUNT)112,112,103
103 WRITE(IOUT,119)MANY,(IBUFFR(LEAST),LEAST=1,KOUNT)
MANY=MANY+1
IF(MANY-9)105,105,104
104 MANY=1
105 IF(INDEX-NEEDED)106,106,110
106 IF(LINE-MAXLIN)108,107,107
107 IF(INDEX-LAST)112,112,82
108 LINE=LINE+1
KOUNT=0
IF(IFORMT)109,83,109
109 LIMIT=6+LENGTH+MOST
GO TO 84
110 IF(LOCK)113,113,17
C
C RETURN TO CALLING PROGRAM
111 WRITE(IOUT,114)JSTORE
IERR=2
GO TO 113
112 WRITE(IOUT,115)MAXCLM
IERR=1
113 RETURN
114 FORMAT(19H DASAVE - MORE THAN,1I4,11H STATEMENTS)
115 FORMAT(21H DASAVE - FIELD WIDTH,1I3,10H TOO SHORT)
116 FORMAT(6X,10HDIMENSION ,66A1)
117 FORMAT(6X,12HEQUIVALENCE ,66A1)
118 FORMAT(6X,5HDATA ,61A1)
119 FORMAT(5X,1I1,66A1)
120 FORMAT(1HC,5X,10HDIMENSION ,66A1)
121 FORMAT(1HC,4X,1I1,66A1)
C985104445547
END
SUBROUTINE DANUMB(KONTRL,NUMBER,IRADIX,LETTER,
1KOUNT,LFTCOL,MAX)
C RENBR(/REPRESENT INTEGER VALUE)
C
C DONALD BARTH, CHEM. DEPT., HARVARD UNIVERSITY
C JAN 2, 1970
C
C KONTRL = 0 LEFT JUSTIFIES AT LFTCOL OR AT KOUNT+1
C IF KOUNT IS GREATER THAN LFTCOL.
C KONTRL = 1 RIGHT JUSTIFIES AT LFTCOL.
C NUMBER = NUMBER TO BE INSERTED.
C IRADIX = BASE TO WHICH NUMBER WILL BE EXPRESSED.
C LETTER = ALPHAMERIC BUFFER ARRAY TO BE CODED.
C KOUNT = NUMBER OF LOCATIONS IN LETTER IN USE.
C LFTCOL = LOCATION OF NEW NUMBER.
C LFTCOL = CHARACTERS LEFT OF NUMBER IF KONTRL = 0.
C LFTCOL = POSITION OF RIGHT DIGIT IF KONTRL = 1.
C MAX = DIMENSION OF LETTER ARRAY.
C
C THE ONLY ARGUMENTS RETURNED CHANGED ARE THE
C LETTER ARRAY WHICH IS RETURNED WITH THE NEW NUMBER
C REPRESENTED AT ITS RIGHT END, AND KOUNT WHICH IS
C RETURNED CONTAINING THE NUMBER OF CHARACTERS IN THE
C LETTER ARRAY.
C
DIMENSION LETTER(MAX),IDGT(10)
DATA IDGT/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
DATA IBLANK,IMINUS/1H ,1H-/
C
C EVEN UP RIGHT MARGIN IF NEEDED
KSAVE=KOUNT
KOLLFT=LFTCOL
IF(KOLLFT-MAX)1,1,26
1 IF(KOUNT-MAX)2,26,26
2 IF(KONTRL)26,4,3
3 IF(KOUNT-KOLLFT)6,26,26
4 IF(KOUNT-KOLLFT)5,6,5
5 KOUNT=KOUNT+1
LETTER(KOUNT)=IBLANK
IF(KOUNT-KOLLFT)5,6,6
C
C SET INITIAL POINTERS
6 KNT=0
KEEP=KOUNT+1
IF(NUMBER)8,7,7
C
C POSITIVE NUMBER
7 NUMB=NUMBER
IF(KOUNT-MAX)12,25,25
C
C NEGATIVE NUMBER
8 IF(KEEP-MAX)9,25,25
9 KOUNT=KOUNT+1
LETTER(KOUNT)=IMINUS
C ABSOLUTE VALUE OF A NEGATIVE NUMBER IS DECREMENTED
C BY ONE SINCE, ON A TWO'S COMPLEMENT COMPUTER, THE
C ABSOLUTE VALUE OF THE LARGEST NEGATIVE NUMBER (SIGN
C BIT ON AND ALL OTHER BITS OFF) CANNOT BE REPRESENTED.
C THIS NUMBER CAN BE EASILY OBTAINED IF SIGN BIT IS
C USED FOR STORING INFORMATION IN SETS.
INDEX=NUMBER+1
NUMB=-INDEX
GO TO 12
C
C INSERT DIGITS OF NUMBER
10 INDEX=KOUNT+KNT
11 LETTER(INDEX+1)=LETTER(INDEX)
INDEX=INDEX-1
IF(INDEX-KOUNT)26,12,11
12 KNT=KNT+1
INDEX=NUMB
NUMB=NUMB/IRADIX
INDEX=INDEX-IRADIX*NUMB
IF(NUMBER)13,16,16
13 IF(KNT-1)26,14,16
14 INDEX=INDEX+1
IF(INDEX-IRADIX)16,15,26
15 INDEX=0
NUMB=NUMB+1
16 LETTER(KOUNT+1)=IDGT(INDEX+1)
IF(NUMB)26,18,17
17 IF(KNT+KOUNT-MAX)10,25,25
18 KOUNT=KOUNT+KNT
C
C EVEN UP LEFT MARGIN IF NEEDED
IF(KONTRL)26,26,19
19 IF(KOUNT-KOLLFT)20,26,23
C
C ADD BLANKS TO LEFT MARGIN
20 DO 21 KNT=KEEP,KOUNT
INDEX=KOLLFT-KNT+KEEP
NUMB=KOUNT-KNT+KEEP
21 LETTER(INDEX)=LETTER(NUMB)
INDEX=KOLLFT-KOUNT+KEEP-1
DO 22 KNT=KEEP,INDEX
22 LETTER(KNT)=IBLANK
KOUNT=KOLLFT
GO TO 26
C
C REMOVE EXCESS DIGITS FROM LEFT MARGIN
23 DO 24 KNT=KEEP,KOLLFT
INDEX=KNT+KOUNT-KOLLFT
24 LETTER(KNT)=LETTER(INDEX)
KOUNT=KOLLFT
GO TO 26
25 KOUNT=KSAVE
26 RETURN
C KEEP = SUBSCRIPT AT WHICH INSERT 1ST CHARACTER.
C KNT = NUMBER OF DIGITS ADDED TO ARRAY.
C KSAVE = NUMBER OF CHARACTERS IN ORIGINAL ARRAY.
C NUMB = ABSOLUTE VALUE OF UNUSED PART OF NUMBER.
C423899686864
END
SUBROUTINE DABOTH(INDEX,IFORMT,NAME,KNTLTR,NUMBER,
1IVALUE,LETTER,KOUNT,MAX)
C
C ROUTINE TO CREATE ARRAY NAMES WITH DIMENSION NUMBERS
C
C DONALD BARTH, CHEM. DEPT., HARVARD UNIVERSITY
C
C INDEX = NEGATIVE OR 0, A SYMBOL CONTAINING AT LEAST
C -INDEX CHARACTERS IS PRODUCED IN LETTER
C ARRAY BY COPYING LOCATIONS 1 THRU KNTLTR OF
C NAME ARRAY AND INSERTING RIGHT BLANKS IF
C NECESSARY.
C = 1 OR GREATER, IS LENGTH OF SYMBOL TO BE
C OUTPUT IN LETTER ARRAY BY RIGHT JUSTIFYING
C DIGITS OF NUMBER AND MAKING LEFT CHARACTERS
C BE THOSE IN NAME ARRAY OR THE LETTER ZERO.
C IFORMT = -1, NO NUMBER IS GIVEN ENCLOSED IN
C PARENTHESES.
C = 0, IVALUE IS REPRESENTED ENCLOSED IN
C PARENTHESES TO RIGHT OF SYMBOL.
C = 1 OR GREATER, IVALUE IS REPRESENTED RIGHT
C JUSTIFIED IN A FIELD OF IFORMT LOCATIONS AND
C ENCLOSED IN PARENTHESES TO RIGHT OF SYMBOL.
C NAME = ALPHAMERIC ARRAY READ BY MULTIPLE OF A1
C FORMAT AND CONTAINING LETTERS OF SYMBOL.
C KNTLTR = NUMBER OF SYMBOL CHARACTERS IN NAME ARRAY.
C NUMBER = NUMBER TO BECOME PART OF SYMBOL IF INDEX=1
C OR GREATER.
C IVALUE = NUMBER TO FOLLOW SYMBOL IF IFORMT=1 OR
C GREATER.
C LETTER = ARRAY TO RECEIVE SYMBOL.
C KOUNT = NUMBER OF LOCATIONS OF LETTER ARRAY IN USE.
C MAX = MAXIMUM NUMBER OF LOCATIONS IN LETTER WHICH
C CAN BE FILLED.
C
DIMENSION LETTER(MAX),NAME(KNTLTR)
DATA IBLANK,IZERO,ILPR,IRPR/1H ,1H0,1H(,1H)/
C
C COPY SYMBOL WITHOUT RIGHT JUSTIFIED NUMBER
INIT=KOUNT
IF(INDEX)1,1,8
1 IF(KOUNT+KNTLTR-MAX)2,2,17
2 KOLUMN=0
3 IF(KOLUMN-KNTLTR)4,5,5
4 KOUNT=KOUNT+1
KOLUMN=KOLUMN+1
LETTER(KOUNT)=NAME(KOLUMN)
GO TO 3
5 IF(KOUNT-INDEX-KNTLTR-MAX)7,7,15
6 KOUNT=KOUNT+1
KOLUMN=KOLUMN+1
LETTER(KOUNT)=IBLANK
7 IF(KOLUMN+INDEX)6,13,13
C
C COPY SYMBOL WITH RIGHT JUSTIFIED NUMBER
8 KOLUMN=KOUNT+INDEX
IF(KOLUMN-MAX)9,9,17
9 LONG=KOUNT
CALL DANUMB(1,NUMBER,10,LETTER,KOUNT,KOLUMN,MAX)
KOLUMN=0
10 LONG=LONG+1
IF(LETTER(LONG).NE.IBLANK)GO TO 13
IF(KOLUMN-KNTLTR)12,11,11
11 LETTER(LONG)=IZERO
GO TO 10
12 KOLUMN=KOLUMN+1
LETTER(LONG)=NAME(KOLUMN)
GO TO 10
C
C INSERT NUMBER ENCLOSED IN PARENTHESES
13 IF(IFORMT)17,14,14
14 KOLUMN=KOUNT+IFORMT+1
CALL DANUMB(IFORMT,IVALUE,10,LETTER,KOUNT,KOLUMN,
1MAX-1)
IF(KOUNT-KOLUMN)15,16,16
15 KOUNT=INIT
GO TO 17
16 KOLUMN=KOLUMN-IFORMT
LETTER(KOLUMN)=ILPR
KOUNT=KOUNT+1
LETTER(KOUNT)=IRPR
C
C RETURN TO CALLING PROGRAM
17 RETURN
C353052349589
END