Trailing-Edge
-
PDP-10 Archives
-
decus_20tap2_198111
-
decus/20-0034/reopr.for
There are 6 other files named reopr.for in the archive. Click here to see a list.
C RENBR(REOPR/CONSTRUCT RENBR OPERATOR TABLES)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C THIS PROGRAM CONSTRUCTS THE TABLE USED BY THE FORTRAN
C RENUMBERING PROGRAM RENBR FOR RECOGNIZING THE SINGLE
C CHARACTER FORTRAN OPERATORS SUCH AS +, -, *, / AND
C THE MULTIPLE CHARACTER FORTRAN OPERATORS SUCH AS .EQ.
C AND .NOT.
C
C INPUT TO THIS PROGRAM, READ FROM UNIT IIN, CONSISTS
C OF A FILE CONTAINING A SINGLE OPERATOR LEFT JUSTIFIED
C ON EACH LINE. THE INPUT FILE SHOULD BE TERMINATED BY
C AN EMPTY LINE IF THE END OF FILE TEST IS NOT
C AVAILABLE. ALPHABETIC CHARACTERS IN THE INPUT FILE
C SHOULD EITHER ALL BE UPPER CASE OR ALL BE LOWER CASE.
C
C OUTPUT FROM THIS PROGRAM, WRITTEN ONTO UNIT IOUT,
C CONSISTS OF COMMENT LINES DESCRIBING THE OPERATIONS
C PERFORMED WHEN CHARACTERS ARE MATCHED, FOLLOWED BY
C THE OPERATIONS PERFORMED WHEN THEY ARE NOT MATCHED.
C THESE COMMENT LINES ARE FOLLOWED BY DATA STATEMENTS
C CONTAINING THE CHARACTERS TO BE MATCHED, THE
C LOCATIONS OF THE CHARACTERS TO BE TESTED IF MATCHES
C ARE FOUND, AND THE LOCATIONS OF THE CHARACTERS TO BE
C TESTED IF MATCHES ARE NOT FOUND. ALL ALPHABETIC
C CHARACTERS APPEAR TWICE IN THE OUTPUT, REGARDLESS OF
C THEIR CASE IN THE INPUT FILE, FIRST IN UPPER CASE AND
C THEN IN LOWER CASE TO BE TESTED AGAINST IF MATCHES
C ARE NOT FOUND WITH THE UPPER CASE CHARACTERS. IF
C BOTH CASES ARE NOT NEEDED, THEN THE ENTIRE SECTION OF
C CODE WHICH SEARCHES FOR ALPHABETIC LETTERS AND
C INSERTS THE LOWER CASE CHARACTERS CAN BE REMOVED.
C
C THE FOLLOWING LINES, IF STRIPPED OF THE INITAL 6
C CHARACTERS ON EACH LINE, CONTAIN THE OPERATOR
C DEFINITIONS WHICH WERE READ BY THIS PROGRAM TO
C CONSTRUCT THE TABLE IN THE 1979 VERSION OF RENBR.
C THESE OPERATOR DEFINITIONS MUST BE FOLLOWED BY AN
C EXTRA BLANK LINE IF THE END-OF-FILE TEST IN READ
C STATEMENTS IS NOT AVAILABLE.
C .AND.
C .EQV.
C .EQ.
C .GE.
C .GT.
C .LE.
C .LT.
C .NEQV.
C .NE.
C .NOT.
C .XOR.
C .OR.
C (
C )
C =
C +
C -
C *
C /
C ,
C <
C >
C #
C :
C
C GLOSSARY OF VARIABLE AND ARRAY NAMES
C
C LTRONE = NAME OF ARRAY TO CONTAIN CHARACTERS FORMING
C OPERATORS.
C LTRTWO = NAME OF ARRAY TO CONTAIN LOCATIONS OF NEXT
C CHARACTERS TO BE TESTED IF CURRENT CHARACTER
C MATCHES OR ZERO FOR COMPLETED MATCH.
C LTRTHR = NAME OF ARRAY TO CONTAIN LOCATIONS OF NEXT
C CHARACTERS TO BE TESTED IF CURRENT CHARACTER
C DOES NOT MATCH OR ZERO FOR TOTAL FAILURE.
C LTRDGT = CHARACTERS 0 THROUGH 9.
C LTRABC = UPPER CASE CHARACTERS A THROUGH Z.
C LWRABC = LOWER CASE CHARACTERS A THROUGH Z.
C LTRBFR = BUFFER INTO WHICH EACH OPERATOR IS READ.
C LTRLIN = BUFFER IN WHICH EACH COMMENT LINE IS
C CONSTRUCTED.
C LTRSPL = CHARACTERS IN OPERATORS AFTER DUPLICATES ARE
C REMOVED.
C LTRINI = CHARACTERS ORIGINALLY IN OPERATORS BEFORE
C DUPLICATES WERE REMOVED.
C LOCPNT = USED IN CONSTRUCTION OF COMMENT LINES TO MAP
C FROM THE ORIGINAL CHARACTERS IN LTRINI ARRAY
C TO THE CHARACTERS IN THE LTRSPL ARRAY.
C LOCMCH = USED IN CONSTRUCTION OF COMMENT LINES TO
C CONTAIN SUBSCRIPTS OF CHARACTERS IN LTRSPL
C ARRAY TO BE MATCHED IF CURRENT MATCH
C SUCCEEDS.
C LOCNOT = USED IN CONSTRUCTION OF COMMENT LINES TO
C CONTAIN SUBSCRIPTS OF CHARACTERS IN LTRSPL
C ARRAY TO BE MATCHED IF CURRENT MATCH FAILS.
C MCHPNT = SUBSCRIPTS OF CHARACTERS IN LTRSPL ARRAY TO
C BE TESTED NEXT IF CURRENT MATCH SUCCEEDS OR
C ZERO FOR COMPLETED MATCH.
C NOTPNT = SUBSCRIPTS OF CHARACTERS IN LTRSPL ARRAY TO
C BE TESTED NEXT IF CURRENT MATCH FAILS OR
C ZERO FOR TOTAL FAILURE.
C LNGSPL = NUMBER OF CHARACTERS IN EACH ORIGINAL
C OPERATOR IN LTRINI ARRAY.
C LOCINI = ORIGINAL LOCATION IN LTRINI ARRAY OF THE
C CHARACTERS NOW IN THE LTRSPL ARRAY.
C
DIMENSION LTRONE(6),LTRTWO(6),LTRTHR(6),LTRDGT(10),
1LTRABC(26),LWRABC(26),LTRBFR(10),LTRLIN(120),
2LTRSPL(200),LTRINI(200)
DIMENSION LOCPNT(10),LOCMCH(10),LOCNOT(10),
1MCHPNT(200),NOTPNT(200),LNGSPL(100),LOCINI(200)
C
C MAXONE = DIMENSION OF THE LTRBFR, LOCPNT, LOCMCH AND
C LOCNOT ARRAYS. MAXONE IS THE MAXIMUM NUMBER
C OF CHARACTERS IN A SINGLE OPERATOR. LTRLIN
C SHOULD BE DIMENSIONED TO 12 TIMES MAXONE.
C MAXALL = DIMENSION OF THE LTRSPL, LTRINI, MCHPNT,
C NOTPNT AND LOCINI ARRAYS. MAXALL IS THE
C MAXIMUM NUMBER OF CHARACTERS WHICH CAN BE IN
C THE TABLE AT ANY POINT, INCLUDING CHARACTERS
C WHICH ARE DUPLICATES WHICH ARE REMOVED IN
C THE FIRST PASS AND INCLUDING BOTH CASES OF
C ALPHABETIC CHARACTERS WHICH ARE GENERATED IN
C THE FINAL PASS.
C MAXOPR = DIMENSION OF THE LNGSPL ARRAY. MAXOPR IS
C THE MAXIMUM NUMBER OF OPERATORS WHICH CAN BE
C HANDLED.
C MAXCLM = DIMENSION OF THE LTRLIN ARRAY. THIS IS
C NUMBER OF CHARACTERS, NEGLECTING INITIAL C
C AND SPACE, WHICH CAN BE WRITTEN ON A SINGLE
C COMMENT LINE.
C
DATA MAXONE,MAXALL,MAXOPR,MAXCLM/10,200,100,120/
C
C IIN = UNIT NUMBER FROM WHICH INPUT FILE IS READ.
C IOUT = UNIT NUMBER TO WHICH OUTPUT FILE IS WRITTEN.
C
DATA IIN,IOUT/1,20/
DATA LTRONE/1HL,1HT,1HR,1HO,1HP,1HR/
DATA LTRTWO/1HM,1HC,1HH,1HO,1HP,1HR/
DATA LTRTHR/1HN,1HO,1HT,1HO,1HP,1HR/
DATA LTRSPC/1H /
DATA LTRDGT/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
DATA LTRABC/1HA,1HB,1HC,1HD,1HE,1HF,1HG,1HH,1HI,1HJ,
1 1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,1HS,1HT,
2 1HU,1HV,1HW,1HX,1HY,1HZ/
DATA LWRABC/1Ha,1Hb,1Hc,1Hd,1He,1Hf,1Hg,1Hh,1Hi,1Hj,
1 1Hk,1Hl,1Hm,1Hn,1Ho,1Hp,1Hq,1Hr,1Hs,1Ht,
2 1Hu,1Hv,1Hw,1Hx,1Hy,1Hz/
C
C READ LIST OF OPERATORS
MAXWID=0
KNTOPR=0
KNTSPL=0
1 READ(IIN,2,END=5)LTRBFR
2 FORMAT(100A1)
MAXPRT=MAXONE+1
3 MAXPRT=MAXPRT-1
IF(MAXPRT.LE.0)GO TO 5
IF(LTRBFR(MAXPRT).EQ.LTRSPC)GO TO 3
IF((KNTSPL+MAXPRT).GT.MAXALL)GO TO 5
KNTOPR=KNTOPR+1
LNGSPL(KNTOPR)=MAXPRT
DO 4 I=1,MAXPRT
KNTSPL=KNTSPL+1
LTRSPL(KNTSPL)=LTRBFR(I)
LTRINI(KNTSPL)=LTRBFR(I)
4 LOCINI(KNTSPL)=KNTSPL
IF(MAXWID.LT.MAXPRT)MAXWID=MAXPRT
IF(KNTOPR.LT.MAXOPR)GO TO 1
C
C REMOVE INITIAL MATCHING CHARACTERS FROM OPERATORS
5 KNTSPL=0
LOCEND=0
INDEX=0
JNDEX=0
KNDEX=1
6 IF(INDEX.GE.KNTOPR)GO TO 12
INDEX=INDEX+1
LOCBGN=LOCEND+1
LOCEND=LOCEND+LNGSPL(INDEX)
DO 11 INNER=LOCBGN,LOCEND
IF(JNDEX.EQ.0)GO TO 8
7 KNDEX=JNDEX
IF(LTRSPL(INNER).EQ.LTRSPL(JNDEX))GO TO 10
JNDEX=NOTPNT(JNDEX)
IF(JNDEX.NE.0)GO TO 7
NOTPNT(KNDEX)=KNTSPL+1
GO TO 9
8 MCHPNT(KNDEX)=KNTSPL+1
9 KNTSPL=KNTSPL+1
LTRSPL(KNTSPL)=LTRSPL(INNER)
LOCINI(KNTSPL)=LOCINI(INNER)
NOTPNT(KNTSPL)=0
MCHPNT(KNTSPL)=0
KNDEX=KNTSPL
GO TO 11
10 JNDEX=MCHPNT(JNDEX)
11 CONTINUE
JNDEX=1
GO TO 6
C
C REMOVE TERMINAL MATCHING CHARACTERS FROM OPERATORS
12 INDEX=0
13 INDEX=INDEX+1
IF(INDEX.GE.KNTSPL)GO TO 17
INNER=INDEX
14 INNER=INNER+1
IF(INNER.GT.KNTSPL)GO TO 13
IF(LTRSPL(INDEX).NE.LTRSPL(INNER))GO TO 14
IF(MCHPNT(INDEX).NE.MCHPNT(INNER))GO TO 14
IF(NOTPNT(INDEX).NE.NOTPNT(INNER))GO TO 14
KNTSPL=KNTSPL-1
DO 15 I=INDEX,KNTSPL
LTRSPL(I)=LTRSPL(I+1)
LOCINI(I)=LOCINI(I+1)
MCHPNT(I)=MCHPNT(I+1)
15 NOTPNT(I)=NOTPNT(I+1)
DO 16 I=1,KNTSPL
IF(MCHPNT(I).EQ.INDEX)MCHPNT(I)=INNER
IF(MCHPNT(I).GT.INDEX)MCHPNT(I)=MCHPNT(I)-1
IF(NOTPNT(I).EQ.INDEX)NOTPNT(I)=INNER
16 IF(NOTPNT(I).GT.INDEX)NOTPNT(I)=NOTPNT(I)-1
GO TO 12
C
C INSERT LOWER CASE LETTERS AFTER UPPER CASE LETTERS
17 INDEX=0
18 IF(INDEX.GE.KNTSPL)GO TO 24
IF((KNTSPL+1).GT.MAXALL)GO TO 24
INDEX=INDEX+1
MATCH=0
19 IF(MATCH.GE.26)GO TO 18
MATCH=MATCH+1
IF(LTRSPL(INDEX).EQ.LTRABC(MATCH))GO TO 20
IF(LTRSPL(INDEX).NE.LWRABC(MATCH))GO TO 19
20 KNTSPL=KNTSPL+1
INNER=KNTSPL
21 IF(INNER.LE.INDEX)GO TO 22
LTRSPL(INNER)=LTRSPL(INNER-1)
LOCINI(INNER)=LOCINI(INNER-1)
MCHPNT(INNER)=MCHPNT(INNER-1)
NOTPNT(INNER)=NOTPNT(INNER-1)
INNER=INNER-1
GO TO 21
22 DO 23 I=1,KNTSPL
IF(MCHPNT(I).GT.INDEX)MCHPNT(I)=MCHPNT(I)+1
23 IF(NOTPNT(I).GT.INDEX)NOTPNT(I)=NOTPNT(I)+1
LTRSPL(INDEX)=LTRABC(MATCH)
LTRSPL(INDEX+1)=LWRABC(MATCH)
LOCINI(INDEX+1)=0
NOTPNT(INDEX)=INDEX+1
INDEX=INDEX+1
GO TO 18
C
C CONSTRUCT DIMENSION AND EQUIVALENCE LINES
24 CALL DASAVE(-4,-1,53,10,MCHPNT,
1KNTSPL,LTRSPL,KNTSPL,LTRONE,6,IOUT,IERR)
CALL DASAVE(-4,3,53,10,MCHPNT,
1KNTSPL,LTRSPL,KNTSPL,LTRTWO,6,IOUT,IERR)
CALL DASAVE(-4,3,53,10,NOTPNT,
1KNTSPL,LTRSPL,KNTSPL,LTRTHR,6,IOUT,IERR)
WRITE(IOUT,38)
C
C CONSTRUCT COMMENT LINES
LOCEND=0
KOLUMN=0
INDEX=KNTSPL
25 KOLUMN=KOLUMN+1
INDEX=INDEX/10
IF(INDEX.GT.0)GO TO 25
DO 39 INDEX=1,KNTOPR
LOCBGN=LOCEND+1
LOCEND=LOCEND+LNGSPL(INDEX)
NEWSPL=0
DO 28 INNER=LOCBGN,LOCEND
NEWSPL=NEWSPL+1
MATCH=KNTSPL
26 IF(LOCINI(MATCH).EQ.INNER)GO TO 27
MATCH=MATCH-1
IF(MATCH.GT.0)GO TO 26
27 LTRBFR(NEWSPL)=LTRINI(INNER)
LOCPNT(NEWSPL)=MATCH
LOCMCH(NEWSPL)=0
LOCNOT(NEWSPL)=0
IF(MATCH.LE.0)GO TO 28
LOCMCH(NEWSPL)=MCHPNT(MATCH)
LOCNOT(NEWSPL)=NOTPNT(MATCH)
28 CONTINUE
KOUNT=0
DO 36 IOUTER=1,3
DO 35 INNER=1,MAXWID
IF(INNER.GT.NEWSPL)GO TO 31
IF(IOUTER.EQ.3)GO TO 30
IF(IOUTER.EQ.2)GO TO 29
IVALUE=LOCPNT(INNER)
IF(IVALUE.LE.0)IVALUE=-1
LTRNEW=LTRBFR(INNER)
GO TO 33
29 IF(LOCPNT(INNER).LE.0)GO TO 31
IVALUE=LOCMCH(INNER)
IF(IVALUE.LE.0)GO TO 32
LTRNEW=LTRSPL(IVALUE)
GO TO 33
30 IF(LOCPNT(INNER).LE.0)GO TO 31
IVALUE=LOCNOT(INNER)
IF(IVALUE.LE.0)GO TO 32
IF(LOCINI(IVALUE).EQ.0)IVALUE=NOTPNT(IVALUE)
IF(IVALUE.LE.0)GO TO 32
LTRNEW=LTRSPL(IVALUE)
GO TO 33
31 IVALUE=-1
32 LTRNEW=LTRSPC
33 IF((KOUNT+KOLUMN).GE.MAXCLM)GO TO 37
KOUNT=KOUNT+KOLUMN+1
DO 34 I=1,KOLUMN
KOUNT=KOUNT-1
LTRLIN(KOUNT)=LTRSPC
IF(IVALUE.LT.0)GO TO 34
JVALUE=IVALUE
IVALUE=IVALUE/10
JVALUE=JVALUE-(10*IVALUE)
LTRLIN(KOUNT)=LTRDGT(JVALUE+1)
IF(IVALUE.EQ.0)IVALUE=-1
34 CONTINUE
KOUNT=KOUNT+KOLUMN
LTRLIN(KOUNT)=LTRNEW
35 CONTINUE
36 CONTINUE
37 WRITE(IOUT,38)(LTRLIN(I),I=1,KOUNT)
38 FORMAT(2HC ,120A1)
39 CONTINUE
C
C CONSTRUCT DATA STATEMENTS
WRITE(IOUT,38)
CALL DASAVE(3,-1,53,10,MCHPNT,
1KNTSPL,LTRSPL,KNTSPL,LTRONE,6,IOUT,IERR)
CALL DASAVE(3,3,53,10,MCHPNT,
1KNTSPL,LTRSPL,KNTSPL,LTRTWO,6,IOUT,IERR)
CALL DASAVE(3,3,53,10,NOTPNT,
1KNTSPL,LTRSPL,KNTSPL,LTRTHR,6,IOUT,IERR)
C919568056337
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