Trailing-Edge
-
PDP-10 Archives
-
decuslib10-13
-
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 ,IFREAR,
2IHIHDO,IIN ,ILEVEL,ILPT ,INCR ,INCSAV,INDENT,
3INDSAV,ININAM,INIOPR,INIPRT,INITOC,INRCPY,INRFND,
4IOUT ,IPAGE ,IPASS ,IPOINT,ISPACE,ISPLIT,ISPR ,
5ISTART,ISTN ,ITAB ,ITBL ,ITITLE,ITRACE,ITTY ,
6J ,JBGN ,JBREAK,JEND ,JEOF ,JFORM ,JIN ,
7JIN1 ,JLEVEL,JMPBGN,JMPEND,JOBNUM,JOUT ,JPASS ,
8JPOINT,JSPLIT,JSTN ,JTAB ,JTBL ,JTTY ,K ,
9KBGN ,KEND ,KLEVEL,KMDMAX,KMDMIN,KNDGRP,KNT
C
COMMON/RNBTWO/KNTONE,KNTPNT,KNTSPL,KNTTOC,KNTTWO,
1KOMENT,KOMKNT,KOMNUM,KONTRL,KOUNT ,KPAGE ,KPASS ,
2KPOINT,KPYEND,KSTN ,KTAB ,KUTNUM,KUTPAG,KUTPNT,
3KUTSPL,L ,LCLNUM,LCLPNT,LCLSPL,LEFT ,LEND ,
4LIKE ,LMTTOC,LNGCOM,LNGNAM,LNGNXT,LOWDO ,LOWER ,
5LOWSHO,LOWTOC,LOW1 ,LOW2 ,LPOINT,LPTTTY,LRGNUM,
6LRGPNT,LRGSPL,LRGTOC,LSTKNT,LSTN ,LSTSTN,LTAB ,
7M ,MANY ,MASTER,MAXCOM,MAXEND,MAXLIN,MAXPNT,
8MAXPRT,MAXSPL,MAXTOC,MID ,MODBAS,MODINC,MODMAX,
9MODMIN,MODNEW,MODOLD,MOST ,MOVE ,MSTN ,MTAB
C
COMMON/RNBTHR/N ,NCD ,NEED ,NEWNUM,NEWSTN,
1NONFOR,NOWTOC,NSTN ,NTAB ,NUM ,NXTEND,NXTLST
C
COMMON/RNBFOU/INRSTR(21) ,JPNT(10) ,LINREF(9) ,
1 MCHOPR(51) ,NNEW(1000) ,NOLD(1000) ,NOTOPR(51) ,
2 NUMPNT(5000),NUMPRS(655) ,NUMTOC(112) ,NUMTYP(7)
C
COMMON/RNBFIV/LTRCLN,LTRDDD,LTRDOT,LTREEE,LTREQL,
1LTREXC,LTRHHH,LTRLFT,LTRMNS,LTRNOW,LTRPLS,LTRQOT,
2LTRREF,LTRRIT,LTRSEM,LTRSLA,LTRSPC,LTRTAB,LTR1ST,
3LTR2ND,LWRDDD,LWREEE,LWRHHH
C
COMMON/RNBSIX/LTRABC(26) ,LTRBGN(5) ,LTRBIG(2211),
1 LTRCOM(6) ,LTRDGT(10) ,LTREND(3) ,LTRFLG(8) ,
2 LTRKEY(5) ,LTRNAM(10) ,LTROPR(51) ,LTRPRS(331) ,
3 LTRSPL(2000),LTRSRT(26) ,LTRTOC(168) ,LTRTOP(117) ,
4 LTRTTL(5) ,LTRTYP(55) ,LTRUSE(6) ,LTR120(120) ,
5 LWRABC(26) ,LWRBGN(5) ,LWREND(3) ,LWRFLG(8) ,
6 LWRKEY(5) ,LWRPRS(331) ,LWRSRT(26) ,LWRTTL(5)
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, JOUT AND ITTY ALSO APPEAR IN
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 IN DETERMINING THE SERIAL NUMBERS, LOWER GROUPS WHICH
C CONTAIN MORE THAN 5 NUMBERS ARE EACH CONSIDERED TO BE
C SINGLE GROUPS. THUS, IF THE NUMPRS ARRAY STARTS WITH
C A TYPE 1 TEST, THEN A LONG TYPE 6 TAKING MORE THAN 5
C LOCATIONS, THEN ANOTHER TYPE 1 TEST, THE THIRD TEST
C WILL HAVE 3 AS ITS SERIAL NUMBER EVEN THOUGH IT
C STARTS BEYOND LOCATION 11.
C
C AN INPUT WHICH CONSISTED ONLY OF 2 BLANK LINES WOULD
C RESULT IN A LISTING OF THE PARSER STRUCTURE AND A NEW
C VERSION OF THE INPUT FILE REFERENCING ONLY THE WORDS
C NODES WHICH ARE ACTUALLY USED. THIS NEW VERSION OF
C THE INPUT FILE CAN THEN BE EDITED AND USED TO CHANGE
C THE ACTUAL ORDER OF THE ITEMS IN THE ARRAYS.
C
C IF THE NEW VERSION OF THE INPUT FILE PRODUCED BY THIS
C PROGRAM IS USED DIRECTLY AS THE INPUT FILE THE NEXT
C TIME, WITHOUT CHANGING THE ORDER OF THE ITEMS IN THE
C ARRAYS DEFINED BY THE BLOCK DATA ROUTINE, THEN THE
C RESULTING ARRAYS PRODUCED BY THIS SECOND RUN WILL BE
C ORDERED IN SUCH A MANNER THAT THEY CAN BE EASILY READ
C BUT OF COURSE THE ORDER MAKES NO DIFFERENCE TO THE
C PROGRAM. THE PROCEDURE TO OBTAIN THIS LOGICAL ORDER
C WOULD THUS BE AS FOLLOWS.
C 1. CONSTRUCT AN EMPTY INPUT FILE CONTAINING ONLY TWO
C BLANK LINES.
C 2. RUN THE REFMT PROGRAM.
C 3. RENAME THE RESULTING NEW SUGGESTED INPUT FILE SO
C THAT IT WILL BE READ THE NEXT TIME REFMT IS RUN.
C 4. WITHOUT CHANGING THE ORDER OF THE ARRAYS IN THE
C PARSING TABLE DEFINED BY THE BLOCK DATA ROUTINE,
C RUN THE REFMT PROGRAM AGAIN.
C 5. INSERT THE RESULTING DIMENSION, EQUIVALENCE AND
C DATA STATEMENTS INTO THE BLOCK DATA ROUTINE IN
C PLACE OF THE PREVIOUS VERSION.
C NOW, IF REFMT IS RUN AGAIN EITHER WITH A BLANK INPUT
C FILE, OR ONE SPECIFYING AN UNCHANGED ORDER (1, 2, 3,
C ETC.), A NEW VERSION OF THE INPUT FILE WOULD BE
C PRODUCED WHICH WOULD ALSO SPECIFY AN UNCHANGED ORDER
C (1, 2, 3, ETC.).
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. ACTUAL
C SIZE OF KPNT ARRAY MUST BE STORED IN MAXGRP.
C LPNT = MUST BE DIMENSIONED SAME AS KPNT.
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),LPNT(300),LTRNXT(30),ISAVE(30),
1LTRNM1(6),LTRNM2(6),LTRNM3(6)
C
C FILE NAMES
DOUBLE PRECISION FILINP,FILOUT,FILNXT,FILLPT
C
C MAXGRP = DIMENSION OF KPNT AND LPNT ARRAYS AND MAXIMUM
C NUMBER OF DIFFERENT OPERATIONS IN PARSER
C TABLES.
DATA MAXGRP/300/
C
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 JOUT = UNIT NUMBER TO WHICH NEW INPUT FILE IS
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,JOUT,ILPT,ITTY/1,20,21,22,5/
C
C GET NAMES OF FILES AND OPEN THEM
1 WRITE(ITTY,3)
READ(ITTY,2)FILINP
OPEN(UNIT=IIN,FILE=FILINP,ACCESS='SEQIN',ERR=1)
WRITE(ITTY,4)
READ(ITTY,2)FILOUT
OPEN(UNIT=IOUT,FILE=FILOUT,ACCESS='SEQOUT')
WRITE(ITTY,5)
READ(ITTY,2)FILNXT
OPEN(UNIT=JOUT,FILE=FILNXT,ACCESS='SEQOUT')
WRITE(ITTY,6)
READ(ITTY,2)FILLPT
OPEN(UNIT=ILPT,FILE=FILLPT,ACCESS='SEQOUT')
2 FORMAT(1A10)
3 FORMAT(' FILE SPECIFYING DESIRED ORDER? ',$)
4 FORMAT(' FILE TO WHICH DATA STATEMENTS ARE TO BE WRITTEN? ',$)
5 FORMAT(' FILE TO WHICH NEXT INPUT FILE IS TO BE WRITTEN? ',$)
6 FORMAT(' FILE TO WHICH LISTING IS TO BE WRITTEN? ',$)
C
C DETERMINE SIZE OF ARRAYS
LMTNMB=0
LMTLST=0
L=1
LMTGRP=0
7 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 8 M=1,N
IF(LMTNMB.LT.NUMPRS(J))LMTNMB=NUMPRS(J)
8 J=J+1
N=N+3
9 L=L+5
N=N-5
IF(N.GT.0)GO TO 9
IF(L.LE.LMTNMB)GO TO 7
LMTNMB=L-1
IF(LMTGRP.GT.MAXGRP)GO TO 65
C
C **********************************
C * *
C * RESTRUCTURE THE LTRPRS ARRAY *
C * *
C **********************************
C
C READ NEXT WORD TO BE MOVED
NEXT=1
IATEND=0
10 READ(IIN,11,END=40)(LTRNXT(I),I=1,30)
11 FORMAT(30A1)
IF(NEXT.GT.LMTLST)GO TO 41
LENGTH=30
12 IF(LTRNXT(LENGTH).NE.LTRNON)GO TO 13
LENGTH=LENGTH-1
IF(LENGTH.GT.0)GO TO 12
GO TO 41
C
C LOCATE THIS WORD IN LIST OF CHARACTERS
13 INITAL=NEXT
14 J=1
INDEX=INITAL
15 IF(LTRPRS(INDEX).EQ.LTRNXT(J))GO TO 19
16 INITAL=INITAL+1
IF((INITAL+LENGTH-1).LE.LMTLST)GO TO 14
WRITE(ITTY,17)(LTRNXT(I),I=1,LENGTH)
17 FORMAT(18H WORD NOT MATCHED ,30A1)
IF(ITTY.EQ.IIN)WRITE(ITTY,18)
18 FORMAT(1X)
GO TO 10
19 IF(J.EQ.LENGTH)GO TO 20
INDEX=INDEX+1
J=J+1
GO TO 15
C
C DETERMINE IF MATCH IS LEGAL
20 K=1
N=0
21 IF(NUMPRS(K).EQ.3)GO TO 22
IF(NUMPRS(K).EQ.10)GO TO 22
IF(NUMPRS(K).EQ.13)GO TO 22
IF(NUMPRS(K+1).EQ.INITAL)GO TO 23
GO TO 24
22 IF(LENGTH.NE.1)GO TO 24
IF(NUMPRS(K+1).EQ.INDEX)GO TO 32
23 IF(NUMPRS(K+2).EQ.INDEX)GO TO 32
24 IF(NUMPRS(K+1).EQ.0)GO TO 27
IF(NUMPRS(K+2).EQ.0)GO TO 26
IF(NUMPRS(K+1).LE.INDEX)GO TO 25
IF(NUMPRS(K+2).GT.INDEX)GO TO 30
25 IF(NUMPRS(K+1).GE.INITAL)GO TO 29
GO TO 28
26 IF(NUMPRS(K+1).GT.INDEX)GO TO 30
IF(NUMPRS(K+1).LT.INITAL)GO TO 30
GO TO 29
27 IF(NUMPRS(K+2).GT.INDEX)GO TO 30
28 IF(NUMPRS(K+2).LT.INITAL)GO TO 30
29 N=1
30 M=2
IF(NUMPRS(K).EQ.6)M=NUMPRS(K+2)-NUMPRS(K+1)+2
M=M+3
31 K=K+5
M=M-5
IF(M.GT.0)GO TO 31
IF(K.LT.LMTNMB)GO TO 21
IF(N.NE.0)GO TO 16
C
C CHANGE POINTERS TO CHARACTERS
32 I=1
33 J=I
DO 35 K=1,2
J=J+1
L=NUMPRS(J)
IF(L.LT.NEXT)GO TO 35
IF(L.GT.INDEX)GO TO 35
IF(L.LT.INITAL)GO TO 34
NUMPRS(J)=NEXT+L-INITAL
GO TO 35
34 NUMPRS(J)=L+LENGTH
35 CONTINUE
M=2
IF(NUMPRS(I).EQ.6)M=NUMPRS(I+2)-NUMPRS(I+1)+2
M=M+3
36 I=I+5
M=M-5
IF(M.GT.0)GO TO 36
IF(I.LT.LMTNMB)GO TO 33
C
C MOVE LETTERS UP TO MAKE ROOM FOR INSERTION
37 IF(INITAL.LE.NEXT)GO TO 38
INITAL=INITAL-1
LTRPRS(INDEX)=LTRPRS(INITAL)
INDEX=INDEX-1
GO TO 37
C
C INSERT LETTERS TO BE MOVED
38 DO 39 I=1,LENGTH
LTRPRS(NEXT)=LTRNXT(I)
39 NEXT=NEXT+1
GO TO 10
C
C **********************************
C * *
C * RESTRUCTURE THE NUMPRS ARRAY *
C * *
C **********************************
C
40 IATEND=1
41 DO 42 I=1,LMTGRP
42 KPNT(I)=I
IF(IATEND.NE.0)GO TO 62
NEXT=1
INIT=1
C
C OBTAIN NUMBER OF NEXT GROUP TO BE MOVED
43 READ(IIN,44,END=62)INDEX
44 FORMAT(I)
IF(INDEX.LE.0)GO TO 62
IF(INDEX.LE.LMTGRP)GO TO 46
WRITE(ITTY,45)INDEX
45 FORMAT(13H NUMPRS GROUP,1I5,10H TOO LARGE)
IF(ITTY.EQ.IIN)WRITE(ITTY,18)
GO TO 43
C
C DETERMINE LOCATION AND SIZE OF PRESENT GROUP
46 LCTN=INIT
KNTGRP=NEXT
47 N=2
IF(NUMPRS(LCTN).EQ.6)N=NUMPRS(LCTN+2)-NUMPRS(LCTN+1)+2
N=N+3
LENGTH=0
48 LCTN=LCTN+5
N=N-5
LENGTH=LENGTH+5
IF(N.GT.0)GO TO 48
IF(INDEX.EQ.KPNT(KNTGRP))GO TO 50
KNTGRP=KNTGRP+1
IF(KNTGRP.LE.LMTGRP)GO TO 47
WRITE(ITTY,49)INDEX
49 FORMAT(13H NUMPRS GROUP,1I5,18H ALREADY PROCESSED)
IF(ITTY.EQ.IIN)WRITE(ITTY,18)
GO TO 43
50 IF(KNTGRP.EQ.NEXT)GO TO 60
LCTN=LCTN-LENGTH
C
C UPDATE REFERENCES TO GROUPS BEING SHIFTED
L=1
51 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 53 M=1,N
IF(NUMPRS(J).LT.INIT)GO TO 53
IF(NUMPRS(J).EQ.LCTN)GO TO 52
IF(NUMPRS(J).LT.LCTN)NUMPRS(J)=NUMPRS(J)+LENGTH
GO TO 53
52 NUMPRS(J)=INIT
53 J=J+1
N=N+3
54 L=L+5
N=N-5
IF(N.GT.0)GO TO 54
IF(L.LT.LMTNMB)GO TO 51
C
C MOVE GROUP TO ITS NEW LOCATION
I=LCTN
DO 55 J=1,LENGTH
ISAVE(J)=NUMPRS(I)
55 I=I+1
56 IF(LCTN.LE.INIT)GO TO 57
I=I-1
LCTN=LCTN-1
NUMPRS(I)=NUMPRS(LCTN)
GO TO 56
57 DO 58 J=1,LENGTH
NUMPRS(INIT)=ISAVE(J)
58 INIT=INIT+1
C
C UPDATE RECORD OF WHERE UNPROCESSED GROUPS ARE FOUND
59 IF(KNTGRP.LE.NEXT)GO TO 61
KPNT(KNTGRP)=KPNT(KNTGRP-1)
KNTGRP=KNTGRP-1
GO TO 59
60 INIT=INIT+LENGTH
61 NEXT=NEXT+1
IF(NEXT.LE.LMTGRP)GO TO 43
C
C CONSTRUCT ARRAY CONTAINING LOWER CASE LETTERS
62 DO 64 I=1,LMTLST
LTRNEW=LTRPRS(I)
LWRPRS(I)=LTRNEW
DO 63 J=1,26
IF(LTRNEW.NE.LTRABC(J))GO TO 63
LWRPRS(I)=LWRABC(J)
GO TO 64
63 CONTINUE
64 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,LPNT,
1 JOUT,ILPT)
GO TO 67
C
C KPNT ARRAY TOO SMALL
65 WRITE(ITTY,66)MAXGRP,LMTGRP
66 FORMAT(' INCREASE DIMENSION OF KPNT ARRAY FROM',
11I5,' TO',1I5/' AND THEN RUN THIS PROGRAM AGAIN')
GO TO 67
C
C ALL DONE
67 STOP
END
SUBROUTINE RETREE(LTRPRS,LMTLST,NUMPRS,LMTNMB,KPNT,LPNT,
1 JOUT,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),LPNT(500)
DATA LNGPAG/60/
DATA LTRDOT,LTRNON/1H.,1H /
C
C ****************************************************
C * *
C * NEW INPUT FILE INCLUDING ONLY REFERENCED ITEMS *
C * *
C ****************************************************
C
C DETERMINE WHICH NODES ARE ACTUALLY USED
KPNT(1)=1
NXTTST=1
1 MAXTST=NXTTST
DO 13 NEWTST=1,MAXTST
NOWTST=MAXTST-NEWTST+1
C LOOK FOR A CHAIN OF FAILURES, ALTERNATE TESTS
I2=KPNT(NOWTST)
2 I4=NUMPRS(I2+4)
IF(I4.EQ.0)GO TO 3
IF(NUMPRS(I2).EQ.NUMPRS(I4))GO TO 6
3 IF(NUMPRS(I2).EQ.1)GO TO 6
IF(NUMPRS(I2).EQ.29)GO TO 6
IF(NUMPRS(I2).LT.17)GO TO 4
IF(NUMPRS(I2).LE.24)GO TO 6
4 CONTINUE
GO TO 10
5 I2=I4
I4=NUMPRS(I2+4)
6 DO 7 I1=1,NXTTST
IF(KPNT(I1).EQ.I2)GO TO 8
7 CONTINUE
NXTTST=NXTTST+1
KPNT(NXTTST)=I2
8 IF(I4.EQ.0)GO TO 10
IF(NUMPRS(I2).EQ.NUMPRS(I4))GO TO 5
9 I2=I4
GO TO 2
C CHECK ALL DESTINATIONS TO SEE IF IN LIST
10 L=KPNT(NOWTST)
I2=L
N=2
IF(NUMPRS(L).EQ.16)N=1
IF(NUMPRS(L).EQ.6)N=NUMPRS(L+2)-NUMPRS(L+1)+2
L=L+3
DO 12 M=1,N
IF(NUMPRS(L).LE.0)GO TO 12
DO 11 K=1,NXTTST
IF(KPNT(K).EQ.NUMPRS(L))GO TO 12
11 CONTINUE
NXTTST=NXTTST+1
KPNT(NXTTST)=NUMPRS(L)
IF(NUMPRS(I2).NE.6)GO TO 1
I2=NUMPRS(L)
GO TO 2
12 L=L+1
IF(MAXTST.LT.NXTTST)GO TO 1
13 CONTINUE
C
C ******************************
C * *
C * IDENTIFY CHAINS OF TESTS *
C * *
C ******************************
C
C SORT THE EXIT NODES TO TOP OF LIST
K=MAXTST
L=MAXTST
14 I=KPNT(K)
IF(NUMPRS(I+3).NE.0)GO TO 17
J=K
15 IF(J.EQ.L)GO TO 16
KPNT(J)=KPNT(J+1)
J=J+1
GO TO 15
16 KPNT(L)=I
L=L-1
17 K=K-1
IF(K.GT.0)GO TO 14
C
C GET NEXT NODE WHICH MIGHT START CHAIN
NOWTST=1
KNTGRP=0
18 KNTGRP=KNTGRP+1
LPNT(NOWTST)=KNTGRP
19 LOCTST=KPNT(NOWTST)
IF(NUMPRS(LOCTST).EQ.6)GO TO 23
C
C DETERMINE IF THIS NODE POINTS TO ONE NEXT HIGHER
20 IF(NOWTST.GE.MAXTST)GO TO 27
N=2
IF(NUMPRS(LOCTST).EQ.16)N=1
IF(NUMPRS(LOCTST).EQ.6)N=NUMPRS(LOCTST+2)-NUMPRS(LOCTST+1)+2
I=LOCTST+3
DO 21 M=1,N
L21=NUMPRS(I)
IF(L21.EQ.0)GO TO 21
IF(NUMPRS(L21+3).EQ.0)GO TO 21
IF(L21.EQ.KPNT(NOWTST+1))GO TO 22
21 I=I+1
NOWTST=NOWTST+1
GO TO 18
22 NOWTST=NOWTST+1
LPNT(NOWTST)=KNTGRP
GO TO 19
C
C CHECK FOR END OF FUNCTION 6 CHAIN
23 I=LOCTST+3
N=NUMPRS(LOCTST+2)-NUMPRS(LOCTST+1)+1
DO 26 M=1,N
L21=NUMPRS(I)
24 IF(NUMPRS(L21).EQ.1)GO TO 25
IF(NUMPRS(L21).EQ.29)GO TO 25
GO TO 26
25 IF(NOWTST.EQ.MAXTST)GO TO 26
IF(KPNT(NOWTST+1).NE.L21)GO TO 26
NOWTST=NOWTST+1
LPNT(NOWTST)=KNTGRP
L21=NUMPRS(L21+4)
IF(L21.NE.0)GO TO 24
26 I=I+1
LOCTST=KPNT(NOWTST)
GO TO 20
27 CONTINUE
C
C *****************************
C * *
C * CONNECT CHAINS OF TESTS *
C * *
C *****************************
C
C FIND FIRST NODE NOT IN CURRENT CHAIN
NOWTST=1
28 IF(NOWTST.GT.MAXTST)GO TO 39
IF(NOWTST.EQ.MAXTST)GO TO 30
IF(LPNT(NOWTST).NE.LPNT(NOWTST+1))GO TO 30
29 NOWTST=NOWTST+1
GO TO 28
C
C IF DOES NOT POINT TO NEXT, LOOK FOR NODE IT DOES POINT TO
30 LOCTST=KPNT(NOWTST)
N=2
IF(NUMPRS(LOCTST).EQ.16)N=1
IF(NUMPRS(LOCTST).EQ.6)N=NUMPRS(LOCTST+2)-NUMPRS(LOCTST+1)+2
LOCTST=LOCTST+3
DO 37 M=1,N
L21=NUMPRS(LOCTST)
IF(L21.EQ.0)GO TO 37
IF(NUMPRS(L21+3).EQ.0)GO TO 37
IF(L21.EQ.1)GO TO 37
NXTTST=0
31 NXTTST=NXTTST+1
IF(KPNT(NXTTST).NE.L21)GO TO 31
MAXTGT=NXTTST
MINTGT=NXTTST
C
C FIND BOTTOM NODE IN SECTION POINTED TO
32 IF(MINTGT.LE.1)GO TO 33
IF(LPNT(MINTGT).NE.LPNT(MINTGT-1))GO TO 33
MINTGT=MINTGT-1
GO TO 32
C
C FIND TOP NODE IN SECTION POINTED TO
33 IF(MAXTGT.GE.MAXTST)GO TO 34
IF(LPNT(MAXTGT).NE.LPNT(MAXTGT+1))GO TO 34
MAXTGT=MAXTGT+1
GO TO 33
C
C CHECK IF ARE REALLY AT BOTTOM OF THE SECTION
C ALSO, DON'T MOVE BOTTOM GROUP, NOR GROUP POINTING TO SELF
34 CONTINUE
IF(MINTGT.EQ.1)GO TO 37
IF(MAXTGT.EQ.NOWTST)GO TO 37
IF(MINTGT.NE.NXTTST)GO TO 37
C
C CHANGE CHAIN IDENTIFICATION NUMBERS TO BE SAME IN BOTH PARTS
DO 35 I=MINTGT,MAXTGT
LPNT(I)=LPNT(NOWTST)
35 CONTINUE
C
C IF NODE POINTED TO IS TRULY ALONE, THEN MOVE IT ABOVE NEW ONE
IF(NXTTST.GT.NOWTST)GO TO 36
C
C IF MOVING LOWER NODE, MOVE COLUMN DOWN AND INSERT AT TOP
C MINTGT ... MAXTGT, MAXTGT+1 ... NOWTST
C BECOMES
C MAXTGT+1 ... NOWTST, MINTGT ... MAXTGT
CALL DASWAP(KPNT,MINTGT,MAXTGT,NOWTST)
CALL DASWAP(LPNT,MINTGT,MAXTGT,NOWTST)
NOWTST=NOWTST-1
GO TO 38
C
C IF MOVING HIGHER NODE, SHIFT COLUMN UP AND INSERT ABOVE FIXED NODE
C NOWTST, NOWTST+1 ... MINTGT-1, MINTGT ... MAXTGT
C BECOMES
C NOWTST, MINTGT ... MAXTGT, NOWTST+1 ... MINTGT-1
36 L3=NOWTST+1
L4=MINTGT-1
CALL DASWAP(KPNT,L3,L4,MAXTGT)
CALL DASWAP(LPNT,L3,L4,MAXTGT)
NOWTST=NOWTST+MAXTGT-MINTGT
GO TO 38
C
C PREPARE TO CHECK NEXT DESTINATION IF CANNOT MOVE CURRENT DESTINATI
37 LOCTST=LOCTST+1
C
C DONE MERGING THESE CHAINS
38 GO TO 29
C
C ALL POSSIBLE CHAINS MERGED
39 CONTINUE
C
C *******************************************
C * *
C * ATTEMPT TO MAKE EACH CHAIN BE BETWEEN *
C * THOSE CALLING IT AND ONES IT CALLS *
C * *
C *******************************************
C
C LOOK FOR EXTENT OF INITIAL CHAIN
KOUTER=MAXTST+1
40 MAXBGN=0
JOUTER=KOUTER
KOUTER=0
41 MAXBGN=MAXBGN+1
MINBGN=MAXBGN
42 IF(MAXBGN.GT.MAXTST)GO TO 59
IF(MAXBGN.EQ.MAXTST)GO TO 43
IF(LPNT(MAXBGN).NE.LPNT(MAXBGN+1))GO TO 43
MAXBGN=MAXBGN+1
GO TO 42
C
C FIND ALL CHAINS POINTED TO BY INITIAL CHAIN
43 DO 58 NEWBGN=MINBGN,MAXBGN
IOUTER=KPNT(NEWBGN)
N38=2
IF(NUMPRS(IOUTER).EQ.16)N38=1
IF(NUMPRS(IOUTER).EQ.6)N38=NUMPRS(IOUTER+2)-NUMPRS(IOUTER+1)+2
IOUTER=IOUTER+3
DO 57 M38=1,N38
L21=NUMPRS(IOUTER)
IF(L21.EQ.0)GO TO 57
IF(NUMPRS(L21+3).EQ.0)GO TO 57
IF(L21.EQ.1)GO TO 57
NOWMID=0
44 NOWMID=NOWMID+1
IF(KPNT(NOWMID).NE.L21)GO TO 44
MINMID=NOWMID
MAXMID=NOWMID
C
C LOOK FOR EXTENT OF MIDDLE CHAIN
45 IF(MINMID.LE.1)GO TO 46
IF(LPNT(MINMID).NE.LPNT(MINMID-1))GO TO 46
MINMID=MINMID-1
GO TO 45
46 IF(MAXMID.GE.MAXTST)GO TO 47
IF(LPNT(MAXMID).NE.LPNT(MAXMID+1))GO TO 47
MAXMID=MAXMID+1
GO TO 46
C
C FIND ALL CHAINS POINTED TO BY MIDDLE CHAIN
47 MINEND=MAXTST+1
MAXEND=0
DO 54 NEWMID=MINMID,MAXMID
INNER=KPNT(NEWMID)
N39=2
IF(NUMPRS(INNER).EQ.16)N39=1
IF(NUMPRS(INNER).EQ.6)N39=NUMPRS(INNER+2)-NUMPRS(INNER+1)+2
INNER=INNER+3
DO 53 M39=1,N39
L22=NUMPRS(INNER)
IF(L22.EQ.0)GO TO 53
NOWEND=0
48 NOWEND=NOWEND+1
IF(KPNT(NOWEND).NE.L22)GO TO 48
C
C INSURE NOT POINTING TO SELF
IF(NOWEND.LT.MINMID)GO TO 49
IF(NOWEND.LE.MAXMID)GO TO 53
49 CONTINUE
C
C LOOK FOR EXTENT OF FINAL CHAIN
MININR=NOWEND
MAXINR=NOWEND
50 IF(MININR.LE.1)GO TO 51
IF(LPNT(MININR).NE.LPNT(MININR-1))GO TO 51
MININR=MININR-1
GO TO 50
51 IF(MAXINR.GE.MAXTST)GO TO 52
IF(LPNT(MAXINR).NE.LPNT(MAXINR+1))GO TO 52
MAXINR=MAXINR+1
GO TO 51
52 IF(MINEND.GT.MININR)MINEND=MININR
IF(MAXEND.LT.MAXINR)MAXEND=MAXINR
53 INNER=INNER+1
54 CONTINUE
C
C MAXBGN MAXMID MAXEND
C . . . .
C NEWBGN .......... NOWMID NEWMID .......... NOWEND
C . . . .
C MINBGN MINMID MINEND
C
C INSURE THAT MIDDLE SECTION CAN ACTUALLY BE MOVED
IF(MINMID.EQ.1)GO TO 57
IF(MINMID.EQ.MINBGN)GO TO 57
C
C DON'T ALLOW MISSING FINAL, OR FINAL THAT OVERLAPS INITIAL
IF(MINEND.GT.MAXEND)GO TO 57
IF(MINEND.LE.MAXBGN)GO TO 57
C
C CHECK IF MIDDLE SECTION IS BELOW INITIAL OR ABOVE FINAL
IF(MINMID.GT.MAXEND)GO TO 55
IF(MAXMID.GE.MINBGN)GO TO 57
C
C MIDDLE FUNCTION BELOW INITIAL AND FINAL FUNCTIONS
C MOVE MIDDLE FUNCTION BETWEEN THESE
C
C NOWEND NOWEND
C . .
C . .
C NEWBGN . BECOMES NOWMID
C . . .
C . . .
C NOWMID NEWBGN
C
CALL DASWAP(KPNT,MINMID,MAXMID,MAXBGN)
CALL DASWAP(LPNT,MINMID,MAXMID,MAXBGN)
GO TO 56
C
C MIDDLE FUNCTION ABOVE INITIAL AND FINAL FUNCTIONS
C MOVE MIDDLE FUNCTION BETWEEN THESE
C
C NOWMID NOWEND
C . . .
C . . .
C . NOWEND BECOMES NOWMID
C . .
C . .
C NEWBGN NEWBGN
C
55 L1=MAXBGN+1
L2=MINMID-1
CALL DASWAP(KPNT,L1,L2,MAXMID)
CALL DASWAP(LPNT,L1,L2,MAXMID)
C
C RESCAN ENTIRE TREE IF MOVING MIDDLE COULD NOT LEAD TO LOOP
56 KOUTER=KOUTER+1
57 IOUTER=IOUTER+1
58 CONTINUE
GO TO 41
59 CONTINUE
IF(KOUTER.LE.1)GO TO 60
IF(KOUTER.LT.JOUTER)GO TO 40
60 CONTINUE
C
C *********************************************************
C * *
C * WRITE LIST OF REFERENCED WORDS INTO NEW OUTPUT FILE *
C * *
C *********************************************************
C
J=0
61 I=J+1
IF(I.GT.LMTLST)GO TO 68
NOWTST=0
62 NOWTST=NOWTST+1
IF(NOWTST.LE.MAXTST)GO TO 63
J=I
GO TO 61
63 K=KPNT(NOWTST)
IF(NUMPRS(K).EQ.3)GO TO 64
IF(NUMPRS(K).EQ.10)GO TO 64
IF(NUMPRS(K).EQ.13)GO TO 64
IF(NUMPRS(K+1).NE.I)GO TO 62
IF(NUMPRS(K+2).LE.I)GO TO 65
J=NUMPRS(K+2)
GO TO 66
64 IF(NUMPRS(K+1).EQ.I)GO TO 65
IF(NUMPRS(K+2).NE.I)GO TO 62
65 J=I
GO TO 66
66 WRITE(JOUT,67)(LTRPRS(K),K=I,J)
67 FORMAT(40A1)
GO TO 61
68 WRITE(JOUT,69)
69 FORMAT(1X)
C
C LIST REFERENCED NODES
DO 74 NXTTST=1,MAXTST
L=1
NOWTST=0
70 NOWTST=NOWTST+1
IF(KPNT(NXTTST).EQ.L)GO TO 72
N=2
IF(NUMPRS(L).EQ.16)N=1
IF(NUMPRS(L).EQ.6)N=NUMPRS(L+2)-NUMPRS(L+1)+2
N=N+3
71 L=L+5
N=N-5
IF(N.GT.0)GO TO 71
GO TO 70
72 WRITE(JOUT,73)NOWTST
73 FORMAT(I4)
74 CONTINUE
75 WRITE(JOUT,76)
76 FORMAT(1X)
C
C ******************************
C * *
C * LIST WORDS IN DICTIONARY *
C * *
C ******************************
C
KNTPAG=0
IRETRN=1
GO TO 217
77 WRITE(ILPT,78)
78 FORMAT(11X,'WORDS IN DICTIONARY'/1X)
KNTLIN=KNTLIN+2
J=0
79 M=0
80 I=J+1
IF(I.GT.LMTLST)GO TO 95
K=1
81 IF(NUMPRS(K).EQ.3)GO TO 87
IF(NUMPRS(K).EQ.10)GO TO 87
IF(NUMPRS(K).EQ.13)GO TO 87
IF(NUMPRS(K+1).NE.I)GO TO 88
IF(NUMPRS(K+2).LE.I)GO TO 90
J=I-1
IF(M.EQ.0)GO TO 84
IRETRN=2
IF(KNTLIN.GE.LNGPAG)GO TO 217
82 WRITE(ILPT,83)(LTRPRS(N),N=M,J)
83 FORMAT(11X,8HNOT USED,1X,40A1)
KNTLIN=KNTLIN+1
84 IRETRN=3
IF(KNTLIN.GE.LNGPAG)GO TO 217
85 J=NUMPRS(K+2)
WRITE(ILPT,86)I,J,(LTRPRS(K),K=I,J)
86 FORMAT(11X,2I4,1X,40A1)
KNTLIN=KNTLIN+1
GO TO 79
87 IF(NUMPRS(K+1).EQ.I)GO TO 90
IF(NUMPRS(K+2).EQ.I)GO TO 90
88 N=2
IF(NUMPRS(K).EQ.6)N=NUMPRS(K+2)-NUMPRS(K+1)+2
N=N+3
89 K=K+5
N=N-5
IF(N.GT.0)GO TO 89
IF(K.LT.LMTNMB)GO TO 81
J=I
IF(M.EQ.0)M=I
GO TO 80
90 J=I-1
IF(M.EQ.0)GO TO 92
IRETRN=4
IF(KNTLIN.GE.LNGPAG)GO TO 217
91 WRITE(ILPT,83)(LTRPRS(N),N=M,J)
KNTLIN=KNTLIN+1
92 IRETRN=5
IF(KNTLIN.GE.LNGPAG)GO TO 217
93 J=I
WRITE(ILPT,94)I,LTRPRS(I)
94 FORMAT(15X,1I4,1X,40A1)
KNTLIN=KNTLIN+1
GO TO 79
95 CONTINUE
C
C *********************************************
C * *
C * FOR EACH FUNCTION, LIST NODES AND WORDS *
C * *
C *********************************************
C
IRETRN=6
GO TO 217
96 WRITE(ILPT,97)
97 FORMAT(11X,'GROUPS USING FUNCTIONS AND WORDS MATCHED')
KNTLIN=KNTLIN+1
J=0
I=1
98 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
99 I=I+5
N=N-5
IF(N.GT.0)GO TO 99
IF(I.LT.LMTNMB)GO TO 98
I=0
100 I=I+1
IF(I.GT.J)GO TO 123
M=0
K=0
L=1
101 IF(NUMPRS(L).NE.I)GO TO 103
IF(K.GE.10)GO TO 105
102 K=K+1
KPNT(K)=L
103 N=2
IF(NUMPRS(L).EQ.6)N=NUMPRS(L+2)-NUMPRS(L+1)+2
N=N+3
104 L=L+5
N=N-5
IF(N.GT.0)GO TO 104
IF(L.LT.LMTNMB)GO TO 101
IF(K.EQ.0)GO TO 114
105 IRETRN=7
IF(M.NE.0)GO TO 106
IF((KNTLIN+2).GE.LNGPAG)GO TO 217
GO TO 107
106 IF(KNTLIN.GE.LNGPAG)GO TO 217
107 IF(M.NE.0)GO TO 111
WRITE(ILPT,108)
108 FORMAT(1X)
INDEX=KPNT(1)
GO TO 141
109 KNTLIN=KNTLIN+2
M=1
WRITE(ILPT,110)I,(KPNT(N),N=1,K)
110 FORMAT(11X,1H(,1I2,1H),10I5)
GO TO 113
111 WRITE(ILPT,112)(KPNT(N),N=1,K)
112 FORMAT(15X,10I5)
113 KNTLIN=KNTLIN+1
K=0
IF(L.LT.LMTNMB)GO TO 102
114 CONTINUE
C
C PRINT WHICH WORDS ARE REFERENCED BY THIS FUNCTION
IF(M.EQ.0)GO TO 100
II=0
115 L=LMTLST+1
K=1
116 IF(NUMPRS(K).NE.I)GO TO 119
IF(NUMPRS(K).EQ.3)GO TO 117
IF(NUMPRS(K).EQ.10)GO TO 117
IF(NUMPRS(K).EQ.13)GO TO 117
IF(NUMPRS(K+1).GE.L)GO TO 119
IF(NUMPRS(K+1).LE.II)GO TO 119
L=NUMPRS(K+1)
M=NUMPRS(K+2)
GO TO 119
117 IF(NUMPRS(K+1).GE.L)GO TO 118
IF(NUMPRS(K+1).LE.II)GO TO 118
L=NUMPRS(K+1)
M=L
118 IF(NUMPRS(K+2).GE.L)GO TO 119
IF(NUMPRS(K+2).LE.II)GO TO 119
L=NUMPRS(K+2)
M=L
119 N=2
IF(NUMPRS(K).EQ.6)N=NUMPRS(K+2)-NUMPRS(K+1)+2
N=N+3
120 K=K+5
N=N-5
IF(N.GT.0)GO TO 120
IF(K.LT.LMTNMB)GO TO 116
IF(L.GT.LMTLST)GO TO 100
IRETRN=8
IF(KNTLIN.GE.LNGPAG)GO TO 217
121 WRITE(ILPT,122)(LTRPRS(N),N=L,M)
122 FORMAT(17X,40A1)
KNTLIN=KNTLIN+1
II=M
IF(II.LT.LMTLST)GO TO 115
GO TO 100
123 CONTINUE
C
C ****************************************
C * *
C * DESCRIBE TESTS PERFORMED BY PARSER *
C * *
C ****************************************
C
IRETRN=9
GO TO 217
124 WRITE(ILPT,125)
125 FORMAT(11X,'DESCRIPTION OF TEST PERFORMED',7X,'SUCCESS',
17X,'FAILURE'//11X,'WHAT BGNLTR ENDLTR OKGOTO NOGOTO ',
2' WHAT OK NO WHAT OK NO'/11X,'WHERE (SERIAL) REFERE',
3'NCEDBY'//11X,'FUNCTION 6 HAS MANY SUCCESS TRANSFERS A',
4'ND 1 FAILURE TRANSFER')
IGROUP=1
INDEX=1
KNTLIN=KNTLIN+6
C
C INDICATE IF THIS IS A NEW GROUP
C ALWAYS CONSIDER TERMINAL CELL AS NEW GROUP
ITYPE6=0
126 ILOOP=1
127 IF(ILOOP.EQ.1)GO TO 173
IF(INDEX.EQ.1)GO TO 132
IF(NUMPRS(INDEX+3).EQ.0)GO TO 129
N=2
IF(NUMPRS(LSTNDX).EQ.6)N=NUMPRS(LSTNDX+2)-NUMPRS(LSTNDX+1)+2
IF(NUMPRS(LSTNDX).EQ.16)N=1
LSTNDX=LSTNDX+3
DO 128 J=1,N
IF(NUMPRS(LSTNDX).EQ.INDEX)GO TO 132
LSTNDX=LSTNDX+1
128 CONTINUE
IF(INDEX.LE.ITYPE6)GO TO 132
129 IF((KNTLIN+KNTNEW+1).LE.LNGPAG)GO TO 130
WRITE(ILPT,131)
IRETRN=10
GO TO 217
130 WRITE(ILPT,131)
131 FORMAT(11X,'------------------')
GO TO 135
132 IF((KNTLIN+KNTNEW+1).LE.LNGPAG)GO TO 133
WRITE(ILPT,134)
IRETRN=11
GO TO 217
133 WRITE(ILPT,134)
134 FORMAT(1X)
135 KNTLIN=KNTLIN+KNTNEW
C
C TEST FOR RANGE OF FUNCTION OF TYPE 6
IF(NUMPRS(INDEX).NE.6)GO TO 140
N=NUMPRS(INDEX+2)-NUMPRS(INDEX+1)+1
ITYPE6=INDEX-5
I=NUMPRS(INDEX+2)-NUMPRS(INDEX+1)+5
136 ITYPE6=ITYPE6+5
I=I-5
IF(I.GT.0)GO TO 136
L=INDEX+3
DO 139 J=1,N
IF(NUMPRS(L).EQ.0)GO TO 139
I=NUMPRS(L)
137 IF(NUMPRS(I).EQ.1)GO TO 138
IF(NUMPRS(I).EQ.29)GO TO 138
GO TO 139
138 IF(ITYPE6.EQ.(I-5))ITYPE6=I
I=NUMPRS(I+4)
IF(I.NE.0)GO TO 137
139 L=L+1
140 CONTINUE
C
C DESCRIBE THE TEST PERFORMED
141 IF(NUMPRS(INDEX).EQ. 1)WRITE(ILPT,142)
IF(NUMPRS(INDEX).EQ. 2)WRITE(ILPT,143)
IF(NUMPRS(INDEX).EQ. 3)WRITE(ILPT,144)
IF(NUMPRS(INDEX).EQ. 4)WRITE(ILPT,145)
IF(NUMPRS(INDEX).EQ. 5)WRITE(ILPT,146)
IF(NUMPRS(INDEX).EQ. 6)WRITE(ILPT,147)
IF(NUMPRS(INDEX).EQ. 7)WRITE(ILPT,148)
IF(NUMPRS(INDEX).EQ. 8)WRITE(ILPT,149)
IF(NUMPRS(INDEX).EQ. 9)WRITE(ILPT,150)
IF(NUMPRS(INDEX).EQ.10)WRITE(ILPT,151)
IF(NUMPRS(INDEX).EQ.11)WRITE(ILPT,152)
IF(NUMPRS(INDEX).EQ.12)WRITE(ILPT,153)
IF(NUMPRS(INDEX).EQ.13)WRITE(ILPT,154)
IF(NUMPRS(INDEX).EQ.14)WRITE(ILPT,155)
IF(NUMPRS(INDEX).EQ.15)WRITE(ILPT,156)
IF(NUMPRS(INDEX).EQ.16)WRITE(ILPT,157)
IF(NUMPRS(INDEX).EQ.17)WRITE(ILPT,158)
IF(NUMPRS(INDEX).EQ.18)WRITE(ILPT,159)
IF(NUMPRS(INDEX).EQ.19)WRITE(ILPT,160)
IF(NUMPRS(INDEX).EQ.20)WRITE(ILPT,161)
IF(NUMPRS(INDEX).EQ.21)WRITE(ILPT,162)
IF(NUMPRS(INDEX).EQ.22)WRITE(ILPT,163)
IF(NUMPRS(INDEX).EQ.23)WRITE(ILPT,164)
IF(NUMPRS(INDEX).EQ.24)WRITE(ILPT,165)
IF(NUMPRS(INDEX).EQ.25)WRITE(ILPT,166)
IF(NUMPRS(INDEX).EQ.26)WRITE(ILPT,167)
IF(NUMPRS(INDEX).EQ.27)WRITE(ILPT,168)
IF(NUMPRS(INDEX).EQ.28)WRITE(ILPT,169)
IF(NUMPRS(INDEX).EQ.29)WRITE(ILPT,170)
IF(NUMPRS(INDEX).EQ.30)WRITE(ILPT,171)
IF(NUMPRS(INDEX).EQ.31)WRITE(ILPT,172)
142 FORMAT(11X,'IS THIS WORD NEXT, IF SO COPY')
143 FORMAT(11X,'DOES NUMBER APPEAR NEXT')
144 FORMAT(11X,'DOES 1ST CHARACTER APPEAR AS OPERATOR B',
1'EFORE 2ND')
145 FORMAT(11X,'REPLACE NUMBER')
146 FORMAT(11X,'COPY THROUGH )')
147 FORMAT(11X,'IS ANY CHARACTER IN LIST NEXT, BRANCH, ',
1'BUT DO NOT COPY')
148 FORMAT(11X,'COPY TEXT UP TO POINTER')
149 FORMAT(11X,'EXIT WITHOUT PUTTING REST OF LINE IN IN',
1'DEX')
150 FORMAT(11X,'EXIT PUTTING REST OF LINE IN INDEX')
151 FORMAT(11X,'DOES 1ST APPEAR AS OPERATOR BEFORE 2ND ',
1'WHILE (=)')
152 FORMAT(11X,'INDEX COPIED TEXT IGNORING BLANKS')
153 FORMAT(11X,'INDEX ALL BUT LAST CHARACTER OF COPIED ',
1'TEXT')
154 FORMAT(11X,'DOES 1ST APPEAR OUTSIDE OPERATOR BEFORE',
1' 2ND WHILE (=)')
155 FORMAT(11X,'RETURN POINTERS TO START OF UNCOPIED TE',
1'XT')
156 FORMAT(11X,'EXCLUDE COPIED TEXT FROM INDEX')
157 FORMAT(11X,'PUT NEXT IN TABLE OF CONTENTS WITH FAIL',
1' FIELD AS TYPE')
158 FORMAT(11X,'IS WORD SOMEWHERE WHILE (=) BEFORE END ',
1'OF LINE')
159 FORMAT(11X,'IS WORD SOMEWHERE WHILE (=) BEFORE NEXT',
1' NON () OPERATOR')
160 FORMAT(11X,'IS WORD SOMEWHERE WHILE (=) BEFORE NEXT',
1' (')
161 FORMAT(11X,'IS WORD SOMEWHERE WHILE (=) BEFORE NEXT',
1' OPERATOR ( OR )')
162 FORMAT(11X,'IS WORD NEXT WHILE (=) BEFORE END OF LI',
1'NE')
163 FORMAT(11X,'IS WORD NEXT WHILE (=) BEFORE NEXT NON ',
1'() OPERATOR')
164 FORMAT(11X,'IS WORD NEXT WHILE (=) BEFORE NEXT (')
165 FORMAT(11X,'IS WORD NEXT WHILE (=) BEFORE NEXT OPER',
1'ATOR ( OR )')
166 FORMAT(11X,'IS THIS LINE AT START OF PROGRAM')
167 FORMAT(11X,'THIS STATEMENT NUMBER WILL END LOOP, AD',
1'D INDENTATION')
168 FORMAT(11X,'ADD INDENTATION')
169 FORMAT(11X,'REMOVE INDENTATION')
170 FORMAT(11X,'IS THIS WORD NEXT, BUT DO NOT COPY')
171 FORMAT(11X,'POINT BEYOND () EXPRESSION, BUT DO NOT ',
1'COPY')
172 FORMAT(11X,'IS POINTER AT END OF STATEMENT')
IF(IRETRN.EQ.7)GO TO 109
C
C GET THE ITEM ITSELF
173 KNTNEW=2
LINE=0
DO 174 J=1,7
174 LTRONE(J)=LTRNON
IF(NUMPRS(INDEX).EQ.3)GO TO 176
IF(NUMPRS(INDEX).EQ.10)GO TO 176
IF(NUMPRS(INDEX).EQ.13)GO TO 176
L=NUMPRS(INDEX+1)
IF(L.LE.0)GO TO 177
DO 175 J=1,7
IF(L.GT.NUMPRS(INDEX+2))GO TO 177
LTRONE(J)=LTRPRS(L)
175 L=L+1
GO TO 177
176 J=NUMPRS(INDEX+1)
LTRONE(1)=LTRPRS(J)
J=NUMPRS(INDEX+2)
LTRONE(2)=LTRPRS(J)
177 L=INDEX
DO 178 J=1,5
NMBONE(J)=NUMPRS(L)
178 L=L+1
IN=INDEX+4
IF(NUMPRS(IN-1).GT.0)GO TO 180
IF(ILOOP.EQ.1)GO TO 179
WRITE(ILPT,197)NMBONE,LTRONE
179 KNTNEW=KNTNEW+1
GO TO 204
C
C GET THE DESTINATION ITEM IF SUCCESS
180 DO 181 J=1,5
181 LTRTWO(J)=LTRNON
JJ=NUMPRS(IN-1)
IF(NUMPRS(JJ).EQ.3)GO TO 183
IF(NUMPRS(JJ).EQ.10)GO TO 183
IF(NUMPRS(JJ).EQ.13)GO TO 183
L=NUMPRS(JJ+1)
IF(L.LE.0)GO TO 184
DO 182 J=1,5
IF(L.GT.NUMPRS(JJ+2))GO TO 184
LTRTWO(J)=LTRPRS(L)
182 L=L+1
GO TO 184
183 J=NUMPRS(JJ+1)
LTRTWO(1)=LTRPRS(J)
J=NUMPRS(JJ+2)
LTRTWO(2)=LTRPRS(J)
184 NMBTWO(1)=NUMPRS(JJ)
NMBTWO(2)=NUMPRS(JJ+3)
NMBTWO(3)=NUMPRS(JJ+4)
IF(NUMPRS(INDEX).EQ.16)GO TO 186
IF(NUMPRS(INDEX).NE.6)GO TO 185
IF(IN.GT.(INDEX+NUMPRS(INDEX+2)-NUMPRS(INDEX+1)+4))
1GO TO 188
185 IF(NUMPRS(IN).GT.0)GO TO 192
IF(IN.GT.(INDEX+4))GO TO 188
186 IF(ILOOP.EQ.1)GO TO 187
WRITE(ILPT,197)NMBONE,LTRONE,NMBTWO,LTRTWO
187 KNTNEW=KNTNEW+1
GO TO 204
188 KM=IN-1
IF(ILOOP.EQ.1)GO TO 191
IF(LINE.EQ.0)WRITE(ILPT,189)INDEX,IGROUP,NUMPRS(KM),
1NMBTWO,LTRTWO
189 FORMAT(11X,1I4,2H (,1I3,1H),1I4,13X,1I2,2I4,1X,5A1)
IF(LINE.NE.0)WRITE(ILPT,190)NUMPRS(KM),NMBTWO,LTRTWO
190 FORMAT(21X,1I4,13X,1I2,2I4,1X,5A1,1X,1I2,2I4,1X,5A1)
191 KNTNEW=KNTNEW+1
LINE=1
GO TO 204
C
C GET THE DESTINATION ITEM IF FAILURE
192 DO 193 J=1,5
193 LTRTHR(J)=LTRNON
JJ=NUMPRS(IN)
IF(NUMPRS(JJ).EQ.3)GO TO 195
IF(NUMPRS(JJ).EQ.10)GO TO 195
IF(NUMPRS(JJ).EQ.13)GO TO 195
L=NUMPRS(JJ+1)
IF(L.LE.0)GO TO 196
DO 194 J=1,5
IF(L.GT.NUMPRS(JJ+2))GO TO 196
LTRTHR(J)=LTRPRS(L)
194 L=L+1
GO TO 196
195 J=NUMPRS(JJ+1)
LTRTHR(1)=LTRPRS(J)
J=NUMPRS(JJ+2)
LTRTHR(2)=LTRPRS(J)
196 NMBTHR(1)=NUMPRS(JJ)
NMBTHR(2)=NUMPRS(JJ+3)
NMBTHR(3)=NUMPRS(JJ+4)
IF(IN.GT.(INDEX+4))GO TO 199
IF(ILOOP.EQ.1)GO TO 198
WRITE(ILPT,197)NMBONE,LTRONE,NMBTWO,LTRTWO,NMBTHR,
1LTRTHR
197 FORMAT(11X,1I2,4I4,1X,7A1,1X,1I2,2I4,1X,5A1,
11X,1I2,2I4,1X,5A1)
198 KNTNEW=KNTNEW+1
GO TO 203
199 KM=IN-1
IF(ILOOP.EQ.1)GO TO 202
IF(LINE.EQ.0)WRITE(ILPT,200)INDEX,IGROUP,NUMPRS(KM),
1NUMPRS(IN),NMBTWO,LTRTWO,NMBTHR,LTRTHR
200 FORMAT(11X,1I4,2H (,1I3,1H),2I4,9X,1I2,2I4,1X,5A1,
11X,1I2,2I4,1X,5A1)
IF(LINE.NE.0)WRITE(ILPT,201)NUMPRS(KM),NUMPRS(IN),NMBTWO,
1LTRTWO,NMBTHR,LTRTHR
201 FORMAT(21X,2I4,9X,1I2,2I4,1X,5A1,1X,1I2,2I4,1X,5A1)
202 LINE=1
KNTNEW=KNTNEW+1
203 IF(NUMPRS(INDEX).NE.6)GO TO 204
IF(IN.GE.(INDEX+NUMPRS(INDEX+2)-NUMPRS(INDEX+1)+4))
1GO TO 204
IN=IN+2
IF(NUMPRS(IN-1).GT.0)GO TO 180
C
C PRINT THE LIST OF GROUPS WHICH CALL THIS GROUP
204 IK=0
IL=1
205 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 206 J=1,N
IF(NUMPRS(L).NE.INDEX)GO TO 206
IK=IK+1
KPNT(IK)=IL
206 L=L+1
N=N+3
207 IL=IL+5
N=N-5
IF(N.GT.0)GO TO 207
IF(IL.LT.LMTNMB)GO TO 205
IF(IK.EQ.0)GO TO 211
IM=IK
IF(IM.GT.12)IM=12
IF(ILOOP.EQ.1)GO TO 210
IF(LINE.EQ.0)WRITE(ILPT,208)INDEX,IGROUP,
1(KPNT(IL),IL=1,IM)
208 FORMAT(11X,1I4,2H (,1I3,1H),12I4)
IF(LINE.NE.0)WRITE(ILPT,209)(KPNT(IL),IL=1,IM)
IF(IK.GT.12)WRITE(ILPT,209)(KPNT(IL),IL=13,IK)
209 FORMAT(21X,12I4)
210 KNTNEW=KNTNEW+(IK+11)/12
GO TO 215
211 IF(ILOOP.EQ.1)GO TO 214
IF(LINE.EQ.0)WRITE(ILPT,212)INDEX,IGROUP
212 FORMAT(11X,1I4,2H (,1I3,1H),23H *** NOT REFERENCED ***)
IF(LINE.NE.0)WRITE(ILPT,213)
213 FORMAT(21X,23H *** NOT REFERENCED ***)
214 KNTLIN=KNTLIN+1
215 ILOOP=ILOOP+1
IF(ILOOP.EQ.2)GO TO 127
IGROUP=IGROUP+1
N=2
IF(NUMPRS(INDEX).EQ.6)N=NUMPRS(INDEX+2)-NUMPRS(INDEX+1)+2
N=N+3
LSTNDX=INDEX
216 INDEX=INDEX+5
N=N-5
IF(N.GT.0)GO TO 216
IF(INDEX.LT.LMTNMB)GO TO 126
GO TO 219
C
C PAGE HEADING
217 KNTPAG=KNTPAG+1
WRITE(ILPT,218)KNTPAG
218 FORMAT('1',10X,'RENBR PARSER',41X,'PAGE',1I3/1X)
KNTLIN=2
GO TO(77,82,85,91,93,96,107,121,124,130,
1 133)IRETRN
C
C ALL DONE
219 RETURN
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)
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.
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
END
SUBROUTINE DASWAP(IARRAY,LOW,MID,MAX)
C
C DONALD BARTH, CHEMISTRY DEPT., HARVARD UNIVERSITY
C
C ROUTINE TO SWAP ADJACENT SECTIONS OF SINGLE ARRAY
C
C IARRAY = ARRAY CONTAINING SECTIONS TO BE SWAPPED
C LOW = SUBSCRIPT OF LOWEST LOCATION IN LOW SECTION
C MID = SUBSCRIPT OF HIGHEST LOCATION IN LOW SECTION
C MAX = SUBSCRIPT OF HIGHEST LOCATION IN HIGH
C SECTION
C
C SWAP IS PERFORMED BY MOVING VALUES DIRECTLY TO
C LOCATIONS THEY ARE TO OCCUPY IN THE RESULT.
C
C FOR EXAMPLE, TO SWAP ABCD AND 123 IN THE
C FOLLOWING EXAMPLE, 3 IS MOVED TO LOCATION HOLDING C
C WHICH IS MOVED TO LOCATION HOLDING 2 AND SO ON.
C
C A B C D 1 2 3
C . . I-----------I
C . . I--------I .
C . I-----------I .
C . I--------I . .
C I-----------I . .
C I--------I . . .
C . . . I--------I
C
C IARRAY ARRAY AND NEW AND KEEP VARIABLES SHOULD BE
C MADE FLOATING POINT TO SWAP A FLOATING POINT ARRAY.
C
DIMENSION IARRAY(MAX)
IF(LOW.GT.MID)GO TO 5
IF(MID.GE.MAX)GO TO 5
KOUNT=LOW-MAX-1
LAST=MAX
LONGLO=LOW-MID-1
LONGHI=MAX-MID
1 INDEX=LAST+LONGLO
KEEP=IARRAY(LAST)
2 KOUNT=KOUNT+1
NEW=IARRAY(INDEX)
IARRAY(INDEX)=KEEP
KEEP=NEW
IF(INDEX.GT.MID)GO TO 3
INDEX=INDEX+LONGHI
GO TO 2
3 IF(INDEX.EQ.LAST)GO TO 4
INDEX=INDEX+LONGLO
GO TO 2
4 IF(KOUNT.EQ.0)GO TO 5
LAST=LAST-1
GO TO 1
5 RETURN
C107401072377
END