Trailing-Edge
-
PDP-10 Archives
-
decus_20tap2_198111
-
decus/20-0034/refmt.for
There are 6 other files named refmt.for in the archive. Click here to see a list.
COMMON/RNBONE/I ,IALPHA,IBASE ,IBR ,IBREAK,
1IEND ,IENTER,IEOF ,IERR ,IFILL ,IFORM ,IHIHDO,
2IIN ,ILEVEL,ILPT ,INCR ,INCSAV,INDENT,INITOC,
3INRCPY,INRFND,INIOPR,IOUT ,IPAGE ,IPASS ,ISPACE,
4ISPLIT,ISPR ,ISTART,ISTN ,ITAB ,ITBL ,ITITLE,
5ITTY ,J ,JBGN ,JBREAK,JEND ,JEOF ,JFORM ,
6JIN ,JIN1 ,JLEVEL,JMPBGN,JMPEND,JOUT ,JPASS ,
7JSPLIT,JSTN ,JTAB ,JTTY ,K ,KLEVEL,KNDGRP,
8KNT ,MAXPRT,KNTONE,KNTPNT,KNTSPL,KNTTOC,KNTTWO,
9KOMENT,KOMKNT,KOMNUM,KONTRL,KOUNT ,KPAGE
COMMON/RNBTWO/MASTER,KPYEND,KSTN ,KTAB ,KUTNUM,
1KUTPNT,KUTSPL,L ,LCLNUM,LCLPNT,LCLSPL,LEFT ,
2LIKE ,LMTTOC,LOW1 ,LOW2 ,LOWDO ,LOWER ,
3LPTTTY,LRGSPL,LRGNUM,LRGPNT,LRGTOC,LSTKNT,LSTN ,
4LSTSTN,LTAB ,M ,MANY ,MAXEND,MAXLIN,MAXPNT,
5MAXSPL,MAXTOC,MID ,MOST ,MOVE ,MSTN ,MTAB ,
6N ,NCD ,NEED ,NEWNUM,NEWSTN,NONFOR,
7NSTN ,NUM ,LOWTOC,NXTLST,IPOINT,JPOINT,NXTEND,
8KEND ,NTAB ,IFREAR,KPOINT,KBGN ,LEND ,LNGNAM,
9LOWSHO,ININAM,JTBL ,NOWTOC,LPOINT,INIPRT,JOBNUM
COMMON/RNBTHR/MODBAS,MODINC,MODMAX,MODMIN,MODNEW,
1MODOLD,KMDMIN,KMDMAX,ITRACE,LNGCOM,LNGNXT,KPASS
COMMON/RNBFOU/INRSTR(21) ,JPNT (10) ,MCHOPR(50) ,
1 NNEW (1000),NOLD (1000),NOTOPR(50) ,NUMPNT(5000),
2 NUMPRS(515) ,NUMTOC(112) ,NUMTYP(7) ,LINREF(9)
COMMON/RNBFIV/LTRCCC,LTRCLN,LTREQL,LTREXC,LTRHHH,
1LTRLFT,LTRMNS,LTRPLS,LTRQOT,LTRRIT,LTRSEM,LTRSLA,
2LTRSPC,LTRTAB,LWRCCC,LWRHHH,LTRNOW,LTR1ST,LTR2ND,
3LTRREF,LTRDDD,LWRDDD,LTREEE,LWREEE,LTRDOT,LTRSTR
COMMON/RNBSIX/LTRABC(26) ,LTRBGN(5) ,LTRBIG(2211),
1 LTRDGT(10) ,LTREND(3) ,LTRFLG(7) ,LTRKEY(5) ,
2 LTROPR(50) ,LTRPRS(247) ,LTRSPL(2000),LTRTOC(168) ,
3 LTRTOP(117) ,LTRTTL(5) ,LTRTYP(55) ,LTRUSE(6) ,
4 LWRABC(26) ,LWRBGN(5) ,LWREND(3) ,LWRFLG(7) ,
5 LWRKEY(5) ,LWRPRS(247) ,LWRTTL(5) ,LTRNAM(10) ,
6 LTRSRT(26) ,LWRSRT(26) ,LTR120(120)
C RENBR(REFMT/RESTRUCTURE RENBR FORTRAN PARSING TABLES)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C THIS PROGRAM ALLOWS THE ORDER OF WORDS RECOGNIZED BY
C THE PARSER FOR THE FORTRAN RENUMBERING PROGRAM RENBR,
C AND OF THE NUMBERS WITHIN THE TABLE DESCRIBING HOW
C THE PARSING IS DONE, TO BE CHANGED. ALL POINTERS
C WITHIN THE TABLE ARE KEPT CORRECT. THE TREE
C STRUCTURE OF THE TABLE IS ALSO LISTED.
C
C THE BLOCK DATA ROUTINE FROM RENBR AND THE DATA
C STATEMENT GENERATOR FROM THE FASP PACKAGE ARE
C REQUIRED. THE LABELED COMMON STATEMENT IN THIS
C PROGRAM MUST BE IDENTICAL TO THAT IN THE BLOCK DATA
C ROUTINE.
C
C THE ONLY ITEMS WHICH ARE NEEDED FROM THE BLOCK DATA
C ROUTINE ARE THE DEFINITIONS OF THE LTRPRS, LWRPRS,
C NUMPRS, LTRABC AND LWRABC ARRAYS. THE VARIABLES
C NAMED IIN, ILPT, IOUT AND ITTY ALSO APPEAR IN THE
C COMMON BLOCK AND ARE USED IN THIS PROGRAM, BUT THESE
C ARE DEFINED WITHIN THIS PROGRAM AND WOULD NOT NEED TO
C BE IN THE COMMON BLOCK OR TO BE DEFINED IN THE BLOCK
C DATA ROUTINE.
C
C DATA FOR THIS PROGRAM CONSIST OF THE WORDS RECOGNIZED
C BY THE PARSER, ONE WORD PER LINE, TERMINATED BY A
C BLANK LINE. LTRPRS ARRAY WILL BE REORDERED IN THE
C ORDER OF THE INPUT WORDS. ANY WORDS NOT SPECIFIED
C WILL BE MOVED UPWARD IN THE ARRAY. THE BLANK LINE
C FOLLOWING THE WORD SPECIFICATIONS IS NECESSARY EVEN
C IF ALL WORDS IN THE LTRPRS ARRAY ARE INCLUDED.
C
C FOLLOWING THE FIRST SECTION SHOULD BE A LIST OF THE
C SERIAL NUMBERS OF THE GROUPS OF ENTRIES IN THE NUMPRS
C ARRAY IN THE ORDER IN WHICH THESE ARE DESIRED TO BE
C OUTPUT, AGAIN A SINGLE NUMBER PER LINE. GROUPS OF
C ENTRIES IN THE NUMPRS ARRAY EACH CONSIST OF A WHOLE
C NUMBER MULTIPLE OF 5 LOCATIONS. THUS, LOCATIONS 46
C THRU 50 WOULD BE SPECIFIED BY THE NUMBER 10 IF EACH
C OF THE LOWER GROUPS OF ENTRIES CONTAINS 5 LOCATIONS,
C SINCE THESE LOCATIONS FORM THE 10TH GROUP OF
C LOCATIONS IN THE ORIGINAL ARRAY. A ZERO ENTRY OR A
C BLANK LINE TERMINATES THIS SECTION AND ANY ENTRIES
C NOT SPECIFIED WILL BE LEFT IN THEIR PRIOR ORDER
C
C AN INPUT WHICH CONSISTED ONLY OF 2 BLANK LINES WOULD
C RESULT IN MERELY A LISTING OF THE CONNECTION TREE
C REPRESENTED BY THESE TABLES.
C
C KPNT = MUST BE DIMENSIONED AT LEAST AS LARGE AS
C NUMBER OF GROUPS IN NUMPRS ARRAY. WILL BE
C LARGE ENOUGH IF DIMENSIONED TO NUMBER OF
C VALUES IN NUMPRS ARRAY DIVIDED BY 5.
C LTRNXT = MUST BE BIG ENOUGH TO HOLD LONGEST WORD IN
C PARSER.
C ISAVE = MUST BE BIG ENOUGH TO HOLD LARGEST GROUP OF
C NUMBERS IN PARSER. MUST BE DIMENSIONED TO
C NEXT MULTPLE OF 5 EQUAL TO OR GREATER THAN
C SIZE OF GROUP DESCRIBING LONGEST FUNCTION 6
C DESCRIPTION.
DIMENSION KPNT(300),LTRNXT(30),ISAVE(30),LTRNM1(6),
1LTRNM2(6),LTRNM3(6)
DATA LTRNON/1H /
DATA LTRNM1/1HN,1HU,1HM,1HP,1HR,1HS/
DATA LTRNM2/1HL,1HT,1HR,1HP,1HR,1HS/
DATA LTRNM3/1HL,1HW,1HR,1HP,1HR,1HS/
C
C IIN = UNIT NUMBER FROM WHICH INSTRUCTIONS ARE
C READ.
C IOUT = UNIT NUMBER TO WHICH NEW DATA STATEMENTS ARE
C WRITTEN.
C ILPT = UNIT NUMBER TO WHICH LISTING IS WRITTEN.
C ITTY = UNIT NUMBER TO WHICH ERROR MESSAGES ARE
C WRITTEN.
C
DATA IIN,IOUT,ILPT,ITTY/1,20,21,5/
C
C DETERMINE SIZE OF ARRAYS
LMTNMB=0
LMTLST=0
L=1
LMTGRP=0
1 LMTGRP=LMTGRP+1
N=2
IF(NUMPRS(L).EQ.16)N=1
IF(NUMPRS(L).EQ.6)N=NUMPRS(L+2)-NUMPRS(L+1)+2
J=L+3
IF(NUMPRS(L+1).GT.LMTLST)LMTLST=NUMPRS(L+1)
IF(NUMPRS(L+2).GT.LMTLST)LMTLST=NUMPRS(L+2)
DO 2 M=1,N
IF(LMTNMB.LT.NUMPRS(J))LMTNMB=NUMPRS(J)
2 J=J+1
N=N+3
3 L=L+5
N=N-5
IF(N.GT.0)GO TO 3
IF(L.LE.LMTNMB)GO TO 1
LMTNMB=L-1
C
C **********************************
C * *
C * RESTRUCTURE THE LTRPRS ARRAY *
C * *
C **********************************
C
C READ NEXT WORD TO BE MOVED
NEXT=1
4 READ(IIN,5)(LTRNXT(I),I=1,30)
5 FORMAT(30A1)
IF(NEXT.GT.LMTLST)GO TO 34
LENGTH=30
6 IF(LTRNXT(LENGTH).NE.LTRNON)GO TO 7
LENGTH=LENGTH-1
IF(LENGTH.GT.0)GO TO 6
GO TO 34
C
C LOCATE THIS WORD IN LIST OF CHARACTERS
7 INITAL=NEXT
8 J=1
INDEX=INITAL
9 IF(LTRPRS(INDEX).EQ.LTRNXT(J))GO TO 13
10 INITAL=INITAL+1
IF((INITAL+LENGTH-1).LE.LMTLST)GO TO 8
WRITE(ITTY,11)(LTRNXT(I),I=1,LENGTH)
11 FORMAT(18H WORD NOT MATCHED ,30A1)
IF(ITTY.EQ.IIN)WRITE(ITTY,12)
12 FORMAT(1X)
GO TO 4
13 IF(J.EQ.LENGTH)GO TO 14
INDEX=INDEX+1
J=J+1
GO TO 9
C
C DETERMINE IF MATCH IS LEGAL
14 K=1
N=0
15 IF(NUMPRS(K).EQ.3)GO TO 16
IF(NUMPRS(K).EQ.10)GO TO 16
IF(NUMPRS(K).EQ.13)GO TO 16
IF(NUMPRS(K+1).EQ.INITAL)GO TO 17
GO TO 18
16 IF(LENGTH.NE.1)GO TO 18
IF(NUMPRS(K+1).EQ.INDEX)GO TO 26
17 IF(NUMPRS(K+2).EQ.INDEX)GO TO 26
18 IF(NUMPRS(K+1).EQ.0)GO TO 21
IF(NUMPRS(K+2).EQ.0)GO TO 20
IF(NUMPRS(K+1).LE.INDEX)GO TO 19
IF(NUMPRS(K+2).GT.INDEX)GO TO 24
19 IF(NUMPRS(K+1).GE.INITAL)GO TO 23
GO TO 22
20 IF(NUMPRS(K+1).GT.INDEX)GO TO 24
IF(NUMPRS(K+1).LT.INITAL)GO TO 24
GO TO 23
21 IF(NUMPRS(K+2).GT.INDEX)GO TO 24
22 IF(NUMPRS(K+2).LT.INITAL)GO TO 24
23 N=1
24 M=2
IF(NUMPRS(K).EQ.6)M=NUMPRS(K+2)-NUMPRS(K+1)+2
M=M+3
25 K=K+5
M=M-5
IF(M.GT.0)GO TO 25
IF(K.LT.LMTNMB)GO TO 15
IF(N.NE.0)GO TO 10
C
C CHANGE POINTERS TO CHARACTERS
26 I=1
27 J=I
DO 29 K=1,2
J=J+1
L=NUMPRS(J)
IF(L.LT.NEXT)GO TO 29
IF(L.GT.INDEX)GO TO 29
IF(L.LT.INITAL)GO TO 28
NUMPRS(J)=NEXT+L-INITAL
GO TO 29
28 NUMPRS(J)=L+LENGTH
29 CONTINUE
M=2
IF(NUMPRS(I).EQ.6)M=NUMPRS(I+2)-NUMPRS(I+1)+2
M=M+3
30 I=I+5
M=M-5
IF(M.GT.0)GO TO 30
IF(I.LT.LMTNMB)GO TO 27
C
C MOVE LETTERS UP TO MAKE ROOM FOR INSERTION
31 IF(INITAL.LE.NEXT)GO TO 32
INITAL=INITAL-1
LTRPRS(INDEX)=LTRPRS(INITAL)
INDEX=INDEX-1
GO TO 31
C
C INSERT LETTERS TO BE MOVED
32 DO 33 I=1,LENGTH
LTRPRS(NEXT)=LTRNXT(I)
33 NEXT=NEXT+1
GO TO 4
C
C **********************************
C * *
C * RESTRUCTURE THE NUMPRS ARRAY *
C * *
C **********************************
C
34 DO 35 I=1,LMTGRP
35 KPNT(I)=I
NEXT=1
INIT=1
C
C OBTAIN NUMBER OF NEXT GROUP TO BE MOVED
36 READ(IIN,37)INDEX
37 FORMAT(I)
IF(INDEX.LE.0)GO TO 55
IF(INDEX.LE.LMTGRP)GO TO 39
WRITE(ITTY,38)INDEX
38 FORMAT(13H NUMPRS GROUP,1I5,10H TOO LARGE)
IF(ITTY.EQ.IIN)WRITE(ITTY,12)
GO TO 36
C
C DETERMINE LOCATION AND SIZE OF PRESENT GROUP
39 LCTN=INIT
KNTGRP=NEXT
40 N=2
IF(NUMPRS(LCTN).EQ.6)N=NUMPRS(LCTN+2)-NUMPRS(LCTN+1)+2
N=N+3
LENGTH=0
41 LCTN=LCTN+5
N=N-5
LENGTH=LENGTH+5
IF(N.GT.0)GO TO 41
IF(INDEX.EQ.KPNT(KNTGRP))GO TO 43
KNTGRP=KNTGRP+1
IF(KNTGRP.LE.LMTGRP)GO TO 40
WRITE(ITTY,42)INDEX
42 FORMAT(13H NUMPRS GROUP,1I5,18H ALREADY PROCESSED)
IF(ITTY.EQ.IIN)WRITE(ITTY,12)
GO TO 36
43 IF(KNTGRP.EQ.NEXT)GO TO 53
LCTN=LCTN-LENGTH
C
C UPDATE REFERENCES TO GROUPS BEING SHIFTED
L=1
44 N=2
IF(NUMPRS(L).EQ.16)N=1
IF(NUMPRS(L).EQ.6)N=NUMPRS(L+2)-NUMPRS(L+1)+2
J=L+3
DO 46 M=1,N
IF(NUMPRS(J).LT.INIT)GO TO 46
IF(NUMPRS(J).EQ.LCTN)GO TO 45
IF(NUMPRS(J).LT.LCTN)NUMPRS(J)=NUMPRS(J)+LENGTH
GO TO 46
45 NUMPRS(J)=INIT
46 J=J+1
N=N+3
47 L=L+5
N=N-5
IF(N.GT.0)GO TO 47
IF(L.LT.LMTNMB)GO TO 44
C
C MOVE GROUP TO ITS NEW LOCATION
I=LCTN
DO 48 J=1,LENGTH
ISAVE(J)=NUMPRS(I)
48 I=I+1
49 IF(LCTN.LE.INIT)GO TO 50
I=I-1
LCTN=LCTN-1
NUMPRS(I)=NUMPRS(LCTN)
GO TO 49
50 DO 51 J=1,LENGTH
NUMPRS(INIT)=ISAVE(J)
51 INIT=INIT+1
C
C UPDATE RECORD OF WHERE UNPROCESSED GROUPS ARE FOUND
52 IF(KNTGRP.LE.NEXT)GO TO 54
KPNT(KNTGRP)=KPNT(KNTGRP-1)
KNTGRP=KNTGRP-1
GO TO 52
53 INIT=INIT+LENGTH
54 NEXT=NEXT+1
IF(NEXT.LE.LMTGRP)GO TO 36
C
C CONSTRUCT ARRAY CONTAINING LOWER CASE LETTERS
55 DO 57 I=1,LMTLST
LTRNEW=LTRPRS(I)
LWRPRS(I)=LTRNEW
DO 56 J=1,26
IF(LTRNEW.NE.LTRABC(J))GO TO 56
LWRPRS(I)=LWRABC(J)
GO TO 57
56 CONTINUE
57 CONTINUE
C
C WRITE DATA STATEMENTS SPECIFYING PARSER
CALL DASAVE(-4,1,53,10,NUMPRS,
1LMTNMB,LTRPRS,LMTLST,LTRNM1,6,IOUT,IFERR)
CALL DASAVE(-4,-1,53,10,NUMPRS,
1LMTNMB,LTRPRS,LMTLST,LTRNM2,6,IOUT,IFERR)
CALL DASAVE(-4,-1,53,10,NUMPRS,
1LMTNMB,LWRPRS,LMTLST,LTRNM3,6,IOUT,IFERR)
CALL DASAVE(3,1,53,10,NUMPRS,
1LMTNMB,LTRPRS,LMTLST,LTRNM1,6,IOUT,IFERR)
CALL DASAVE(3,-1,53,10,NUMPRS,
1LMTNMB,LTRPRS,LMTLST,LTRNM2,6,IOUT,IFERR)
CALL DASAVE(3,-1,53,10,NUMPRS,
1LMTNMB,LWRPRS,LMTLST,LTRNM3,6,IOUT,IFERR)
C
C CALL FOR LISTING OF SYNTAX TABLE STRUCTURE
CALL RETREE(LTRPRS,LMTLST,NUMPRS,LMTNMB,KPNT,ILPT)
STOP
C643017621152
END
SUBROUTINE RETREE(LTRPRS,LMTLST,NUMPRS,LMTNMB,KPNT,ILPT)
C RENBR(/LIST STRUCTURE OF RENBR PARSER)R=
C
C REFMT ROUTINE TO LIST STRUCTURE OF RENBR SYNTAX
C DRIVING TABLE.
C
C EACH SET OF 5 ENTRIES IS LISTED ON A SINGLE LINE
C TOGETHER WITH THE ALPHAMERIC LETTERS TESTED AGAINST
C FOLLOWED BY AN ABBREVIATED LISTING OF THE SETS
C TRANSFERRED TO IN CASE OF SUCCESS AND FAILURE
C RESPECTIVELY. THE FIRST NUMBER IN THE LINE
C IDENTIFIES THE FUNCTION PERFORMED. THESE FUNCTIONS
C ARE DESCRIBED IN COMMENT CARDS IN THE RENBR BLOCK
C DATA PROGRAM. ON THE NEXT LINE ARE LISTED
C ALL THE SETS WHICH TRANSFER TO THE PRESENT SET.
C
DIMENSION KPNT(500),LTRPRS(500),NUMPRS(500),LTRONE(7),
1LTRTWO(5),LTRTHR(5),NMBONE(5),NMBTWO(3),NMBTHR(3),
2KOLUMN(33),IDUMMY(33),LTRSHO(132)
DATA LTRDOT,LTRNON/1H.,1H /
C
C PRINT CONTENTS OF LIST
WRITE(ILPT,1)
1 FORMAT(20H1WORDS IN DICTIONARY/1X)
J=0
2 M=0
3 I=J+1
IF(I.GT.LMTLST)GO TO 12
K=1
4 IF(NUMPRS(K).EQ.3)GO TO 7
IF(NUMPRS(K).EQ.10)GO TO 7
IF(NUMPRS(K).EQ.13)GO TO 7
IF(NUMPRS(K+1).NE.I)GO TO 8
IF(NUMPRS(K+2).LE.I)GO TO 10
J=I-1
IF(M.NE.0)WRITE(ILPT,5)(LTRPRS(N),N=M,J)
5 FORMAT(1X,8HNOT USED,1X,40A1)
J=NUMPRS(K+2)
WRITE(ILPT,6)I,J,(LTRPRS(K),K=I,J)
6 FORMAT(1X,2I4,1X,40A1)
GO TO 2
7 IF(NUMPRS(K+1).EQ.I)GO TO 10
IF(NUMPRS(K+2).EQ.I)GO TO 10
8 N=2
IF(NUMPRS(K).EQ.6)N=NUMPRS(K+2)-NUMPRS(K+1)+2
N=N+3
9 K=K+5
N=N-5
IF(N.GT.0)GO TO 9
IF(K.LT.LMTNMB)GO TO 4
J=I
IF(M.EQ.0)M=I
GO TO 3
10 J=I-1
IF(M.NE.0)WRITE(ILPT,5)(LTRPRS(N),N=M,J)
J=I
WRITE(ILPT,11)I,LTRPRS(I)
11 FORMAT(5X,1I4,1X,40A1)
GO TO 2
C
C PRINT WHICH GROUPS USE WHICH FUNCTIONS
12 WRITE(ILPT,13)
13 FORMAT(41H1GROUPS USING FUNCTIONS AND WORDS MATCHED/
11X)
J=0
I=1
14 IF(NUMPRS(I).GT.J)J=NUMPRS(I)
N=2
IF(NUMPRS(I).EQ.6)N=NUMPRS(I+2)-NUMPRS(I+1)+2
N=N+3
15 I=I+5
N=N-5
IF(N.GT.0)GO TO 15
IF(I.LT.LMTNMB)GO TO 14
DO 33 I=1,J
M=0
K=0
L=1
16 IF(NUMPRS(L).NE.I)GO TO 22
IF(K.LT.10)GO TO 21
IF(M.NE.0)GO TO 18
WRITE(ILPT,17)I,(KPNT(N),N=1,K)
17 FORMAT(1X,1H(,1I2,1H),10I5)
M=1
GO TO 20
18 WRITE(ILPT,19)(KPNT(N),N=1,K)
19 FORMAT(5X,10I5)
20 K=0
21 K=K+1
KPNT(K)=L
22 N=2
IF(NUMPRS(L).EQ.6)N=NUMPRS(L+2)-NUMPRS(L+1)+2
N=N+3
23 L=L+5
N=N-5
IF(N.GT.0)GO TO 23
IF(L.LT.LMTNMB)GO TO 16
IF(K.EQ.0)GO TO 25
IF(M.NE.0)GO TO 24
WRITE(ILPT,17)I,(KPNT(N),N=1,K)
M=1
GO TO 25
24 WRITE(ILPT,19)(KPNT(N),N=1,K)
C
C PRINT WHICH WORDS ARE REFERENCED BY THIS FUNCTION
25 IF(M.EQ.0)GO TO 33
II=0
26 L=LMTLST+1
K=1
27 IF(NUMPRS(K).NE.I)GO TO 30
IF(NUMPRS(K).EQ.3)GO TO 28
IF(NUMPRS(K).EQ.10)GO TO 28
IF(NUMPRS(K).EQ.13)GO TO 28
IF(NUMPRS(K+1).GE.L)GO TO 30
IF(NUMPRS(K+1).LE.II)GO TO 30
L=NUMPRS(K+1)
M=NUMPRS(K+2)
GO TO 30
28 IF(NUMPRS(K+1).GE.L)GO TO 29
IF(NUMPRS(K+1).LE.II)GO TO 29
L=NUMPRS(K+1)
M=L
29 IF(NUMPRS(K+2).GE.L)GO TO 30
IF(NUMPRS(K+2).LE.II)GO TO 30
L=NUMPRS(K+2)
M=L
30 N=2
IF(NUMPRS(K).EQ.6)N=NUMPRS(K+2)-NUMPRS(K+1)+2
N=N+3
31 K=K+5
N=N-5
IF(N.GT.0)GO TO 31
IF(K.LT.LMTNMB)GO TO 27
IF(L.GT.LMTLST)GO TO 33
WRITE(ILPT,32)(LTRPRS(N),N=L,M)
32 FORMAT(7X,40A1)
II=M
IF(II.LT.LMTLST)GO TO 26
33 CONTINUE
C
C ***************************************
C * *
C * DESCRIBE TREE STRUCTURE OF PARSER *
C * *
C ***************************************
C
WRITE(ILPT,34)
34 FORMAT(40H1TESTS PERFORMED UPON SUCCESS OR FAILURE)
IGROUP=1
INDEX=1
C
C GET THE ITEM ITSELF
35 LINE=0
DO 36 J=1,7
36 LTRONE(J)=LTRNON
IF(NUMPRS(INDEX).EQ.3)GO TO 38
IF(NUMPRS(INDEX).EQ.10)GO TO 38
IF(NUMPRS(INDEX).EQ.13)GO TO 38
L=NUMPRS(INDEX+1)
IF(L.LE.0)GO TO 39
DO 37 J=1,7
IF(L.GT.NUMPRS(INDEX+2))GO TO 39
LTRONE(J)=LTRPRS(L)
37 L=L+1
GO TO 39
38 J=NUMPRS(INDEX+1)
LTRONE(1)=LTRPRS(J)
J=NUMPRS(INDEX+2)
LTRONE(2)=LTRPRS(J)
39 L=INDEX
DO 40 J=1,5
NMBONE(J)=NUMPRS(L)
40 L=L+1
IN=INDEX+4
IF(NUMPRS(IN-1).GT.0)GO TO 41
WRITE(ILPT,56)NMBONE,LTRONE
GO TO 61
C
C GET THE DESTINATION ITEM IF SUCCESS
41 DO 42 J=1,5
42 LTRTWO(J)=LTRNON
JJ=NUMPRS(IN-1)
IF(NUMPRS(JJ).EQ.3)GO TO 44
IF(NUMPRS(JJ).EQ.10)GO TO 44
IF(NUMPRS(JJ).EQ.13)GO TO 44
L=NUMPRS(JJ+1)
IF(L.LE.0)GO TO 45
DO 43 J=1,5
IF(L.GT.NUMPRS(JJ+2))GO TO 45
LTRTWO(J)=LTRPRS(L)
43 L=L+1
GO TO 45
44 J=NUMPRS(JJ+1)
LTRTWO(1)=LTRPRS(J)
J=NUMPRS(JJ+2)
LTRTWO(2)=LTRPRS(J)
45 NMBTWO(1)=NUMPRS(JJ)
NMBTWO(2)=NUMPRS(JJ+3)
NMBTWO(3)=NUMPRS(JJ+4)
IF(NUMPRS(INDEX).EQ.16)GO TO 47
IF(NUMPRS(INDEX).NE.6)GO TO 46
IF(IN.GT.(INDEX+NUMPRS(INDEX+2)-NUMPRS(INDEX+1)+4))
1GO TO 48
46 IF(NUMPRS(IN).GT.0)GO TO 51
IF(IN.GT.(INDEX+4))GO TO 48
47 WRITE(ILPT,56)NMBONE,LTRONE,NMBTWO,LTRTWO
GO TO 61
48 KM=IN-1
IF(LINE.EQ.0)WRITE(ILPT,49)INDEX,IGROUP,NUMPRS(KM),
1NMBTWO,LTRTWO
49 FORMAT(1X,1I4,2H (,1I3,1H),1I4,13X,1I2,2I4,1X,5A1)
IF(LINE.NE.0)WRITE(ILPT,50)NUMPRS(KM),NMBTWO,LTRTWO
50 FORMAT(11X,1I4,13X,1I2,2I4,1X,5A1,1X,1I2,2I4,1X,5A1)
LINE=1
GO TO 61
C
C GET THE DESTINATION ITEM IF FAILURE
51 DO 52 J=1,5
52 LTRTHR(J)=LTRNON
JJ=NUMPRS(IN)
IF(NUMPRS(JJ).EQ.3)GO TO 54
IF(NUMPRS(JJ).EQ.10)GO TO 54
IF(NUMPRS(JJ).EQ.13)GO TO 54
L=NUMPRS(JJ+1)
IF(L.LE.0)GO TO 55
DO 53 J=1,5
IF(L.GT.NUMPRS(JJ+2))GO TO 55
LTRTHR(J)=LTRPRS(L)
53 L=L+1
GO TO 55
54 J=NUMPRS(JJ+1)
LTRTHR(1)=LTRPRS(J)
J=NUMPRS(JJ+2)
LTRTHR(2)=LTRPRS(J)
55 NMBTHR(1)=NUMPRS(JJ)
NMBTHR(2)=NUMPRS(JJ+3)
NMBTHR(3)=NUMPRS(JJ+4)
IF(IN.GT.(INDEX+4))GO TO 57
WRITE(ILPT,56)NMBONE,LTRONE,NMBTWO,LTRTWO,NMBTHR,
1LTRTHR
56 FORMAT(/1H ,1I2,4I4,1X,7A1,1X,1I2,2I4,1X,5A1,
11X,1I2,2I4,1X,5A1)
GO TO 60
57 KM=IN-1
IF(LINE.EQ.0)WRITE(ILPT,58)INDEX,IGROUP,NUMPRS(KM),
1NUMPRS(IN),NMBTWO,LTRTWO,NMBTHR,LTRTHR
58 FORMAT(1X,1I4,2H (,1I3,1H),2I4,9X,1I2,2I4,1X,5A1,
11X,1I2,2I4,1X,5A1)
IF(LINE.NE.0)WRITE(ILPT,59)NUMPRS(KM),NUMPRS(IN),NMBTWO,
1LTRTWO,NMBTHR,LTRTHR
59 FORMAT(11X,2I4,9X,1I2,2I4,1X,5A1,1X,1I2,2I4,1X,5A1)
LINE=1
60 IF(NUMPRS(INDEX).NE.6)GO TO 61
IF(IN.GE.(INDEX+NUMPRS(INDEX+2)-NUMPRS(INDEX+1)+4))
1GO TO 61
IN=IN+2
IF(NUMPRS(IN-1).GT.0)GO TO 41
C
C PRINT THE LIST OF GROUPS WHICH CALL THIS GROUP
61 IK=0
IL=1
62 N=2
IF(NUMPRS(IL).EQ.16)N=1
IF(NUMPRS(IL).EQ.6)N=NUMPRS(IL+2)-NUMPRS(IL+1)+2
L=IL+3
DO 63 J=1,N
IF(NUMPRS(L).NE.INDEX)GO TO 63
IK=IK+1
KPNT(IK)=IL
63 L=L+1
N=N+3
64 IL=IL+5
N=N-5
IF(N.GT.0)GO TO 64
IF(IL.LT.LMTNMB)GO TO 62
IF(IK.EQ.0)GO TO 67
IM=IK
IF(IM.GT.12)IM=12
IF(LINE.EQ.0)WRITE(ILPT,65)INDEX,IGROUP,
1(KPNT(IL),IL=1,IM)
65 FORMAT(1X,1I4,2H (,1I3,1H),12I4)
IF(LINE.NE.0)WRITE(ILPT,66)(KPNT(IL),IL=1,IM)
IF(IK.GT.12)WRITE(ILPT,66)(KPNT(IL),IL=13,IK)
66 FORMAT(11X,12I4)
GO TO 70
67 IF(LINE.EQ.0)WRITE(ILPT,68)INDEX,IGROUP
68 FORMAT(1X,1I4,2H (,1I3,1H),23H *** NOT REFERENCED ***)
IF(LINE.NE.0)WRITE(ILPT,69)
69 FORMAT(11X,23H *** NOT REFERENCED ***)
70 IGROUP=IGROUP+1
N=2
IF(NUMPRS(INDEX).EQ.6)N=NUMPRS(INDEX+2)-NUMPRS(INDEX+1)+2
N=N+3
71 INDEX=INDEX+5
N=N-5
IF(N.GT.0)GO TO 71
IF(INDEX.LT.LMTNMB)GO TO 35
C
C DRAW STRUCTURE OF TREE
WRITE(ILPT,72)
72 FORMAT(27H1DIAGRAM OF TESTS PERFORMED/1X)
KOUNT=0
INDEX=1
73 N=2
IF(NUMPRS(INDEX).EQ.16)N=1
IF(NUMPRS(INDEX).EQ.6)N=NUMPRS(INDEX+2)-NUMPRS(INDEX+1)+2
L=INDEX+3
M=0
DO 74 I=1,N
IF(NUMPRS(L).LE.0)GO TO 75
IF(M.EQ.0)KOUNT=KOUNT+2
M=M+1
KOUNT=KOUNT+1
NUMPRS(KOUNT)=NUMPRS(L)
74 L=L+1
75 N=N+3
IF(M.LE.0)GO TO 76
J=KOUNT-M-1
NUMPRS(J)=M+1
NUMPRS(J+1)=INDEX
76 INDEX=INDEX+5
N=N-5
IF(N.GT.0)GO TO 76
IF(INDEX.LT.LMTNMB)GO TO 73
NOWCLM=0
77 CALL DATREE(1,1,0,1,KOUNT,
1NUMPRS,1,33,NOWCLM,KOLUMN,IDUMMY,KIND,
2NEWCLM)
IF(KIND.LE.1)GO TO 81
K=0
DO 79 I=1,NOWCLM
IF(I.GE.NEWCLM)GO TO 78
LTRSHO(K+1)=LTRNON
LTRSHO(K+2)=LTRNON
LTRSHO(K+3)=LTRNON
LTRSHO(K+4)=LTRDOT
K=K+4
GO TO 79
78 J=KOLUMN(I)
J=NUMPRS(J)
M=K+4
CALL DANUMB(1,J,10,LTRSHO,K,M,132)
79 CONTINUE
WRITE(ILPT,80)(LTRSHO(I),I=1,K)
80 FORMAT(1X,132A1)
GO TO 77
81 STOP
C787956574294
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
SUBROUTINE DATREE(KLIMB ,KOMPAR,ITYPE ,MINNOD,MAXNOD,
1 NODES ,MINCLM,MAXCLM,NOWCLM,KOLUMN,INITAL,KIND ,
2 NEWCLM)
C RENBR(/NODES IN NEXT LINE OF TREE REPRESENTATION)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C ROUTINE TO RETURN THE NODES WHICH WOULD BE IN NEXT
C LINE OF THE REPRESENTATION OF A SIMPLE TREE
C STRUCTURE. THE NODES ARE IDENTIFIED TO CALLING
C PROGRAM BY SUBSCRIPTS, AND ARE NOT REPRESENTED IN A
C FORM WHICH CAN BE DIRECTLY WRITTEN WITH A MULTIPLE OF
C AN A1 FORMAT.
C
C KLIMB = 0, ENTIRE TREE IS TO BE REPRESENTED
C = 1, ONLY PORTION OF TREE STARTING AT NODE
C HAVING IDENTIFICATION NUMBER IN NODES ARRAY
C EQUAL TO INPUT VALUE OF KOMPAR IS TO BE
C REPRESENTED
C KOMPAR = IF KLIMB=1, THEN KOMPAR IS EQUAL TO NUMBER
C IN NODES ARRAY WHICH IDENTIFIES NODE AT BASE
C OF TREE. PORTION OF TREE BELOW THIS NODE
C WILL NOT BE REPRESENTED.
C ITYPE = 0, EACH GROUP IN NODES ARRAY CONSISTS OF
C NUMBER OF ITEMS WHICH ARE IDENTIFIED IN
C GROUP FOLLOWED BY IDENTIFICATION OF CALLING
C ITEM AND THEN BY IDENTIFICATIONS OR SOME OR
C ALL OF ITEMS WHICH IT CALLS. NODES ARRAY IS
C TERMINATED BY GROUP CONTAINING ONLY SINGLE
C ZERO. IF ITEM 10 CALLS 11 AND 12, AND ITEM
C 11 CALLS 12 AND 13, THEN NODES ARRAY WOULD
C CONTAIN
C 3, 10, 11, 12, 3, 11, 12, 13 AND 0
C = 1, EACH GROUP IN NODES ARRAY CONSISTS OF
C NUMBER OF ITEMS IDENTIFIED IN GROUP FOLLOWED
C BY IDENTIFICATION OF ITEM CALLED AND THEN BY
C IDENTIFICATIONS OF SOME OR ALL OF ITEMS
C CALLING IT. NODES ARRAY IS TERMINATED BY
C GROUP CONTAINING ONLY SINGLE ZERO. FOR
C ABOVE EXAMPLE IN WHICH 12 IS CALLED BY BOTH
C 10 AND 11, IN WHICH 11 IS CALLED BY 10 AND
C IN WHICH 13 IS CALLED BY 11, NODES ARRAY
C WOULD CONTAIN
C 3, 12, 10, 11, 2, 11, 10, 2, 13, 11 AND 0
C MINNOD = LOWEST SUBSCRIPT TO USE IN NODES ARRAY
C MAXNOD = DIMENSION OF NODES ARRAY
C NODES = ARRAY CONTAINING NODE IDENTIFIERS
C MINCLM = SUBSCRIPT OF FIRST LOCATION IN KOLUMN ARRAY
C MAXCLM = SUBSCRIPT OF FINAL LOCATION IN KOLUMN ARRAY
C WHICH IS AVAILABLE FOR USE
C NOWCLM = MUST BE SET TO MINCLM-1 BEFORE THIS ROUTINE
C IS FIRST CALLED TO REPRESENT PARTICULAR
C TREE. RETURNED CONTAINING HIGHEST SUBSCRIPT
C USED IN KOLUMN ARRAY TO REPRESENT CURRENT
C LINE AND MUST BE SENT TO SUBSEQUENT CALL OF
C THIS ROUTINE UNCHANGED
C KOLUMN = ARRAY RETURNED CONTAINING SUBSCRIPTS IN
C NODES ARRAY OF THOSE NODES ON CURRENT LINE.
C CONTENTS OF KOLUMN ARRAY MUST BE SENT TO
C SUBSEQUENT CALL OF THIS ROUTINE UNCHANGED.
C CONTENTS OF KOLUMN ARRAY ARE IGNORED WHEN
C THIS ROUTINE IS CALLED WITH NOWCLM LESS THAN
C MINCLM
C INITAL = ARRAY DIMENSIONED SAME AS KOLUMN ARRAY, BUT
C WHICH IS USED ONLY FOR TRANSFER OF VALUES
C FROM ONE CALL OF THIS ROUTINE TO NEXT.
C CONTENTS OF THIS ARRAY MUST NOT BE CHANGED
C BETWEEN CALLS TO THIS ROUTINE UNTIL KIND IS
C RETURNED CONTAINING 1 INDICATING THAT TREE
C HAS BEEN COMPLETED.
C KIND = 1, RETURNED IF REPRESENTATION OF TREE HAD
C BEEN FINISHED BY PREVIOUS CALL
C = 2, LINE IN REPRESENTATION IS BEING RETURNED
C IN KOLUMN(MINCLM) THROUGH AND INCLUDING
C KOLUMN(NOWCLM)
C = 3, SAME AS KIND=2 EXCEPT THAT REPRESENTATION
C IS TERMINATED AT LOOP END
C = 4, SAME AS KIND=2 EXCEPT THAT NOT ALL NODES
C COULD BE REPRESENTED DUE TO TOO LITTLE ROOM
C IN KOLUMN ARRAY
C = 5, KLIMB WAS INPUT CONTAINING 1 AND NOWCLM
C CONTAINING MINCLM-1 INDICATING THAT PARTIAL
C TREE WAS DESIRED, BUT NODE IDENTIFIED BY
C KOMPAR COULD NOT BE FOUND IN NODES ARRAY.
C NO NODES ARE BEING RETURNED IN KOLUMN ARRAY,
C AND NOWCLM IS RETURNED CONTAINING MINCLM-1.
C NEWCLM = RETURNED CONTAINING LOWEST SUSCRIPT OF
C KOLUMN ARRAY WHICH HAS BEEN RETURNED
C CHANGED. INPUT VALUE IS IGNORED
C
DIMENSION NODES(MAXNOD),KOLUMN(MAXCLM),INITAL(MAXCLM)
C
KIND=1
IF(NOWCLM.GE.MINCLM)GO TO 21
NOWCLM=MINCLM-1
NEWCLM=MINCLM
LIMIT=MINNOD
IF(KLIMB.EQ.0)GO TO 3
C
C FIND ROOT IF SPECIFIED BY CALLING PROGRAM
1 ISIZE=NODES(LIMIT)
IF(ISIZE.LE.0)GO TO 25
JTEST=LIMIT
LOWER=LIMIT
LIMIT=LIMIT+ISIZE+1
IF(LIMIT.GT.MAXNOD)GO TO 25
2 LOWER=LOWER+1
IF(LOWER.GE.LIMIT)GO TO 1
IF(NODES(LOWER).NE.KOMPAR)GO TO 2
GO TO 14
C
C FIND NEXT ROOT IF NOT SPECIFIED BY CALLING PROGRAM
3 ISIZE=NODES(LIMIT)
IF(ISIZE.LE.0)GO TO 26
JTEST=LIMIT
LOWER=LIMIT+1
LIMIT=LOWER+ISIZE
IF(LIMIT.GT.MAXNOD)GO TO 26
IF(ITYPE.EQ.0)GO TO 9
IF(ISIZE.LE.1)GO TO 5
4 LOWER=LOWER+1
IF(LOWER.GE.LIMIT)GO TO 3
5 IDNTFY=NODES(LOWER)
6 NODTST=MINNOD
7 ISIZE=NODES(NODTST)
IF(ISIZE.LE.0)GO TO 10
ITEST=NODTST+1
NODTST=ITEST+ISIZE
IF(NODTST.GT.MAXNOD)GO TO 10
IF(ITYPE.EQ.0)GO TO 8
IF(ISIZE.LE.1)GO TO 7
8 IF(NODES(ITEST).NE.IDNTFY)GO TO 7
IF(ITYPE.NE.0)GO TO 4
IF(ITEST.LT.LOWER)GO TO 3
GO TO 14
9 IDNTFY=NODES(LOWER)
10 NODTST=MINNOD
11 ISIZE=NODES(NODTST)
IF(ISIZE.LE.0)GO TO 6
ITEST=NODTST+1
NODTST=ITEST+ISIZE
IF(NODTST.GT.MAXNOD)GO TO 6
IF(ITYPE.EQ.0)GO TO 12
IF(ISIZE.LE.1)GO TO 13
12 ITEST=ITEST+1
IF(ITEST.GE.NODTST)GO TO 11
13 IF(NODES(ITEST).NE.IDNTFY)GO TO 12
IF(ITYPE.EQ.0)GO TO 3
IF(ITEST.LT.LOWER)GO TO 4
C
C INSERT NEW NODE ONTO BRANCH
14 IF(NOWCLM.GE.MAXCLM)GO TO 24
NOWCLM=NOWCLM+1
KOLUMN(NOWCLM)=LOWER
INITAL(NOWCLM)=JTEST
IDNTFY=NODES(LOWER)
LIMIT=MINNOD
KIND=2
C
C CHECK THAT BRANCH DOES NOT CONTAIN A LOOP
J=MINCLM
15 IF(J.GE.NOWCLM)GO TO 16
I=KOLUMN(J)
IF(NODES(I).EQ.NODES(LOWER))GO TO 23
J=J+1
GO TO 15
C
C SEARCH FOR NEXT NODE ALONG BRANCH
16 ISIZE=NODES(LIMIT)
IF(ISIZE.LE.0)GO TO 20
JTEST=LIMIT
LOWER=LIMIT+1
LIMIT=LOWER+ISIZE
IF(LIMIT.GT.MAXNOD)GO TO 20
IF(ITYPE.EQ.0)GO TO 18
ITEST=LOWER
17 ITEST=ITEST+1
IF(ITEST.GE.LIMIT)GO TO 16
IF(NODES(ITEST).NE.IDNTFY)GO TO 17
GO TO 14
18 IF(NODES(LOWER).NE.IDNTFY)GO TO 16
19 LOWER=LOWER+1
IF(LOWER.GE.LIMIT)GO TO 16
GO TO 14
C
C BACK UP TO PREVIOUS NODE IF CURRENT NODE COMPLETED
20 IF(KIND.NE.1)GO TO 26
21 LOWER=KOLUMN(NOWCLM)
JTEST=INITAL(NOWCLM)
LIMIT=JTEST+NODES(JTEST)+1
NEWCLM=NOWCLM
NOWCLM=NOWCLM-1
IF(NOWCLM.LT.MINCLM)GO TO 22
I=KOLUMN(NOWCLM)
IDNTFY=NODES(I)
IF(ITYPE.EQ.0)GO TO 19
GO TO 16
22 IF(KLIMB.NE.0)GO TO 26
IF(ITYPE.EQ.0)GO TO 3
GO TO 4
C
C RETURN TO CALLING PROGRAM
23 KIND=3
GO TO 26
24 KIND=4
GO TO 26
25 KIND=5
26 RETURN
C660045846000
END