Trailing-Edge
-
PDP-10 Archives
-
decuslib20-05
-
decus/20-0141/damenu.for
There are 2 other files named damenu.for in the archive. Click here to see a list.
C RENBR(DAMENU/WRITE DATA STATEMENTS DEFINING COMMANDS)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C THIS PROGRAM CONSTRUCTS DATA STATEMENTS WHICH DEFINE
C THE DICTIONARY REQUIRED BY FASP ROUTINES SUCH AS
C DAWORD AND DAHEST FOR WORD IDENTIFICATION. THE FIRST
C 80 CHARACTERS ARE READ FROM EACH LINE OF THE INPUT
C FILE. THE FIRST LINE OF THE INPUT FILE IS COPIED
C INTO THE OUTPUT FILE AS A COMMENT AND SHOULD DESCRIBE
C THE CONTENTS OF THE FILE. THE SECOND LINE OF THE
C INPUT FILE MUST CONTAIN SEPARATED BY SPACES THE NAMES
C BY WHICH THE FOLLOWING 6 ITEMS ARE TO BE REPRESENTED
C IN THE DATA STATEMENTS GENERATED BY THIS PROGRAM
C 1 THE VARIABLE WHICH CONTAINS THE TOTAL NUMBER OF
C CHARACTERS IN ALL WORDS IN THE DICTIONARY.
C 2 THE VARIABLE WHICH CONTAINS THE TOTAL NUMBER OF
C WORDS IN THE DICTIONARY.
C 3 THE ARRAY WHICH CONTAINS IDENTICAL VALUES FOR
C WORDS WHICH ARE SYNONYMS. THESE VALUES ARE
C SPECIFIED FOR EACH WORD BY A NUMBER AT THE LEFT
C END OF EACH SUBSEQUENT LINE IN THE FILE. DATA
C STATEMENTS DEFINING THIS ARRAY ARE GENERATED ONLY
C IF SOME VALUES WITHIN THE ARRAY ARE SPECIFIED,
C BUT THE NAME OF THE ARRAY MUST STILL BE SUPPLIED.
C 4 THE ARRAY WHICH CONTAINS THE CHARACTERS FORMING
C THE WORDS IN THE DICTIONARY.
C 5 THE ARRAY WHICH CONTAINS THE LENGTH OF EACH WORD
C IN THE DICTIONARY.
C 6 THE ARRAY WHICH CONTAINS THE ARGUMENT TYPE
C ASSOCIATED WITH EACH WORD IN THE DICTIONARY.
C THIS IS SPECIFIED FOR EACH WORD BY A NUMBER AT
C THE RIGHT END OF EACH SUBSEQUENT LINE IN THE
C FILE. DATA STATEMENTS DEFINING THIS ARRAY ARE
C GENERATED ONLY IF SOME VALUES WITHIN THE ARRAY
C ARE SPECIFIED, BUT THE NAME OF THE ARRAY MUST
C STILL BE SUPPLIED.
C IF THE SECOND LINE DOES NOT CONTAIN AT LEAST 6 GROUPS
C OF CHARACTERS, THEN ADDITIONAL NAMES WILL BE READ
C FROM SUBSEQUENT LINES UNTIL 6 HAVE BEEN SPECIFIED.
C
C EACH SUBSEQUENT LINE CONTAINS A WORD IDENTIFICATION
C NUMBER FOLLOWED BY THE SPELLING OF THE WORD. IF AN
C ABBREVIATION OF THIS WORD IS TO BE RECOGNIZED EVEN
C THOUGH IT IS NOT UNIQUE ACROSS THE ENTIRE DICTIONARY,
C THEN THIS ABBREVIATION OR ABBREVIATIONS SHOULD FOLLOW
C THE COMPLETE SPELLING SEPARATED FROM IT AND EACH
C OTHER BY COMMAS, WITH THE LONGEST ABBREVIATIONS
C COMING FIRST. SPACES ARE IGNORED AT THE START OR END
C OF THE SPELLING OF A WORD. IF TWO OR MORE WORDS
C APPEAR ON A SINGLE LINE BUT ARE NOT SEPARATED BY
C COMMAS, THEN THE RESULTING DICTIONARY WILL INCLUCE
C THESE WORDS AS A SINGLE ENTRY IN WHICH THESE WORDS
C ARE SEPARATED BY SINGLE SPACES. FOR EXAMPLE, IF THE
C FIRST 3 LETTERS OF THE WORD DUPLICATE THOSE OF SOME
C OTHER WORD, BUT THE WORD BEING DESCRIBED ON THE
C CURRENT LINE IS TO BE SELECTED BY ITS 1, 2 OR 3
C LETTER ABBREVIATIONS, THEN THE FULL SPELLING WOULD BE
C FOLLOWED BY A COMMA AND THE 3 LETTER ABBREVIATION,
C THEN BY A COMMA AND THE 2 LETTER ABBREVIATION AND
C FINALLY BY A COMMA AND THE SINGLE LETTER
C ABBREVIATION. (ALTERNATIVELY, THE ABBREVIATIONS CAN
C BE ENTERED IN SUBSEQUENT LINES, BUT AGAIN THE FULL
C SPELLING SHOULD APPEAR FIRST AND BE FOLLOWED BY ITS
C LONGEST ABBREVIATION.) A SINGLE DIGIT APPEARING AT
C THE RIGHT END OF EACH LINE WOULD DESCRIBE FOR THE
C ROUTINE DAHEST THAT THE WORDS APPEARING TO THE LEFT
C OF THE DIGIT ARE TO TAKE ARGUMENTS OF THE FOLLOWING
C TYPES
C 0 (OR ABSENT NUMBER) WILL NOT ALLOW THE WORD TO
C ACCEPT ANY ARGUMENTS.
C 1 WILL ALLOW THE WORD TO ACCEPT MULTIPLE ARGUMENTS
C OF THE SAME TYPE AS ITS FIRST ARGUMENT.
C 2 WILL ALLOW THE WORD TO ACCEPT MULTIPLE WORD
C ARGUMENTS.
C 3 WILL ALLOW THE WORD TO ACCEPT MULTIPLE NUMERIC
C ARGUMENTS.
C 4 WILL ALLOW THE WORD TO ACCEPT MULTIPLE TEXT
C STRING ARGUMENTS.
C 5 6 7 OR 8, SAME AS 1 2 3 OR 4 RESPECTIVELY, EXCEPT
C THAT NUMBERS IF FOUND ARE RETURNED AS REALS
C RATHER THAN AS INTEGERS.
C 9 WILL ALLOW WORD TO ACCEPT MULTIPLE TEXT STRINGS
C WHICH BEGIN WITH ANY CHARACTER WHICH IS NOT A
C PUNCTUATION MARK.
C THE INPUT FILE IS TERMINATED BY A BLANK LINE.
C
C FOR EXAMPLE, IF THE DICTIONARY CONTAINS THE WORD
C EXAMINE WHICH IS TO
C BE IDENTIFIED BY THE NUMBER 135
C BE ABBREVIATED AS EITHER EX OR E
C TAKE MULTIPLE ARGUMENTS OF SAME TYPE AS ITS FIRST
C AND THE WORD EXCHANGE WHICH IS TO
C BE IDENTIFIED BY THE NUMBER -8
C NOT BE ABBREVIATED AS EITHER EX OR E
C TAKE MULTIPLE NUMERIC ARGUMENTS
C THEN THE INPUT FILE WOULD CONTAIN
C
C 135 EXAMINE,EX,E 1
C -8 EXCHANGE 3
C
C OR
C
C 135 EXAMINE 1
C 135 EX 1
C 135 E 1
C -8 EXCHANGE 3
C
DIMENSION IBUFFR(80),KMDLTR(1000),KMDTYP(200),
1KMDWID(200),KMDARG(200),INAME(6),JNAME(6),KNAME(6),
2LNAME(6),MNAME(6),NNAME(6),IDIGIT(10)
DOUBLE PRECISION NAMSRC,NAMOUT
DATA IDIGIT/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
DATA ISPACE,KOMMA,KLEFT,KRIGHT/1H ,1H,,1H(,1H)/
C
C MAXBFR = NUMBER OF CHARACTERS READ INTO IBUFFR ARRAY
C FROM EACH LINE OF INPUT FILE
C MAXCMD = DIMENSION OF KMDTYP AND KMDWID AND KMDARG
C ARRAYS, MAXIMUM NUMBER OF WORDS IN
C DICTIONARY
C MAXLTR = DIMENSION OF KMDLTR ARRAY, MAXIMUM NUMBER OF
C CHARACTERS IN ALL WORDS IN DICTIONARY
C IDSK = UNIT NUMBER CONTAINING INPUT FILE
C JDSK = UNIT NUMBER TO WHICH OUTPUT IS WRITTEN
DATA MAXBFR,MAXLTR,MAXCMD/80,1000,200/
DATA IDSK,JDSK/1,20/
C
C ASK USER FOR FILE NAMES AND OPEN FILES
TYPE 1
1 FORMAT(19H INPUT FILE NAME = ,$)
ACCEPT 2,NAMSRC
2 FORMAT(1A10)
OPEN(UNIT=IDSK,FILE=NAMSRC,ACCESS='SEQIN')
TYPE 3
3 FORMAT(20H OUTPUT FILE NAME = ,$)
ACCEPT 2,NAMOUT
OPEN(UNIT=JDSK,FILE=NAMOUT,ACCESS='SEQOUT')
C
C KNTLTR = NUMBER OF CHARACTERS IN KMDLTR ARRAY
C KNTCMD = NUMBER OF COMMANDS IN KMDTYP, KMDWID AND
C KMDARG ARRAYS
KNTLTR=0
KNTCMD=0
IFANY=0
JFANY=0
C
C READ FIRST LINE OF FILE CONTAINING COMMENT
READ(IDSK,19)IBUFFR
LIMIT=MAXBFR+1
4 LIMIT=LIMIT-1
IF(LIMIT.LE.1)GO TO 5
IF(IBUFFR(LIMIT).EQ.ISPACE)GO TO 4
5 WRITE(JDSK,6)(IBUFFR(I),I=1,LIMIT)
6 FORMAT(1HC,80A1)
WRITE(JDSK,6)
C
C READ SECOND LINE OF FILE CONTAINING ARRAY NAMES
DO 7 I=1,6
INAME(I)=ISPACE
7 JNAME(I)=ISPACE
KONTRL=0
8 READ(IDSK,19)IBUFFR
LOCAL=0
DO 17 INDEX=1,MAXBFR
IF(IBUFFR(INDEX).EQ.ISPACE)GO TO 16
IF(IBUFFR(INDEX).EQ.KOMMA)GO TO 16
IF(LOCAL.NE.0)GO TO 9
KONTRL=KONTRL+1
IF(KONTRL.GT.6)GO TO 18
9 LOCAL=LOCAL+1
IF(LOCAL.GT.6)GO TO 17
GO TO(10,11,12,13,14,15),KONTRL
10 ILONG=LOCAL
INAME(ILONG)=IBUFFR(INDEX)
GO TO 17
11 JLONG=LOCAL
JNAME(JLONG)=IBUFFR(INDEX)
GO TO 17
12 KLONG=LOCAL
KNAME(KLONG)=IBUFFR(INDEX)
GO TO 17
13 LLONG=LOCAL
LNAME(LLONG)=IBUFFR(INDEX)
GO TO 17
14 MLONG=LOCAL
MNAME(MLONG)=IBUFFR(INDEX)
GO TO 17
15 NLONG=LOCAL
NNAME(NLONG)=IBUFFR(INDEX)
GO TO 17
16 LOCAL=0
17 CONTINUE
IF(KONTRL.LT.6)GO TO 8
C
C READ THE DESCRIPTIONS OF THE COMMANDS
18 READ(IDSK,19,END=30)IBUFFR
19 FORMAT(80A1)
ITYPE=0
C
C GET IDENTIFYING NUMBER
INDEX=1
CALL DAIHFT(0,1,0,IBUFFR,MAXBFR,
1INDEX,KIND,ISHIFT,JSHIFT,KSHIFT,LSHIFT,ITYPE)
C
C GET ARGUMENT TYPE
LIMIT=MAXBFR+1
20 LIMIT=LIMIT-1
IF(LIMIT.LT.INDEX)GO TO 30
IF(IBUFFR(LIMIT).EQ.ISPACE)GO TO 20
DO 21 I=1,10
IF(IBUFFR(LIMIT).NE.IDIGIT(I))GO TO 21
JTYPE=I-1
KTYPE=1
GO TO 22
21 CONTINUE
LIMIT=LIMIT+1
JTYPE=0
KTYPE=0
C
C STORE COMMAND NAME OR NAMES
22 KNTINI=KNTLTR
JSPACE=0
KSPACE=0
23 IF(INDEX.LT.LIMIT)GO TO 24
IF(JSPACE.EQ.0)GO TO 18
GO TO 29
24 IF(IBUFFR(INDEX).EQ.KOMMA)GO TO 28
IF(IBUFFR(INDEX).EQ.ISPACE)GO TO 26
IF(JSPACE.LE.0)GO TO 25
IF(KNTINI.GE.MAXLTR)GO TO 30
KNTINI=KNTINI+1
KMDLTR(KNTINI)=ISPACE
KSPACE=100
25 IF(KNTINI.GE.MAXLTR)GO TO 30
KNTINI=KNTINI+1
KMDLTR(KNTINI)=IBUFFR(INDEX)
JSPACE=-1
GO TO 27
26 IF(JSPACE.LT.0)JSPACE=1
27 INDEX=INDEX+1
GO TO 23
28 INDEX=INDEX+1
IF(JSPACE.EQ.0)GO TO 23
29 IF(KNTCMD.GE.MAXCMD)GO TO 30
KNTCMD=KNTCMD+1
KMDTYP(KNTCMD)=ITYPE
KMDWID(KNTCMD)=KNTINI-KNTLTR+KSPACE
KNTLTR=KNTINI
KMDARG(KNTCMD)=JTYPE
IF(KIND.EQ.3)IFANY=1
IF(KTYPE.NE.0)JFANY=1
GO TO 22
C
C PREPARE TO WRITE COMMENT LINES DESCRIBING COMMANDS
30 IF(JFANY.EQ.0)GO TO 58
WRITE(JDSK,31)
31 FORMAT(1HC,5X,25HMULTIPLE NUMERIC LENGTH/1HC)
INDEX=0
IRIGHT=0
LAST=KMDTYP(1)+1
C
C OBTAIN NEXT COMMAND TO BE INCLUDED IN COMMENTS
32 INDEX=INDEX+1
IF(INDEX.GT.KNTCMD)GO TO 56
ILEFT=IRIGHT+1
I=KMDWID(INDEX)
IF(I.GE.100)I=I-100
IRIGHT=IRIGHT+I
C
C TEST IF COMMAND IS ABBREVIATION OF PREVIOUS COMMAND
IF(IFANY.EQ.0)GO TO 34
IF(LAST.NE.KMDTYP(INDEX))GO TO 34
IF((JRIGHT-JLEFT).LE.(IRIGHT-ILEFT))GO TO 34
J=JLEFT
DO 33 I=ILEFT,IRIGHT
IF(KMDLTR(I).NE.KMDLTR(J))GO TO 34
33 J=J+1
J=IRIGHT-ILEFT+1
K=JLEFT+J
WRITE(JDSK,45)J,(KMDLTR(I),I=ILEFT,IRIGHT),KLEFT,
1(KMDLTR(I),I=K,JRIGHT),KRIGHT
GO TO 32
C
C COMMENT DESCRIBING COMMAND WHICH IS NOT ABBREVIATED
34 LAST=KMDTYP(INDEX)
JLEFT=ILEFT
JRIGHT=IRIGHT
JTYPE=KMDARG(INDEX)+1
J=IRIGHT-ILEFT+1
GO TO(35,36,37,38,39,40,41,42,43,44),JTYPE
35 WRITE(JDSK,46)LAST,J,(KMDLTR(I),I=ILEFT,IRIGHT)
GO TO 32
36 WRITE(JDSK,47)LAST,J,(KMDLTR(I),I=ILEFT,IRIGHT)
GO TO 32
37 WRITE(JDSK,48)LAST,J,(KMDLTR(I),I=ILEFT,IRIGHT)
GO TO 32
38 WRITE(JDSK,49)LAST,J,(KMDLTR(I),I=ILEFT,IRIGHT)
GO TO 32
39 WRITE(JDSK,50)LAST,J,(KMDLTR(I),I=ILEFT,IRIGHT)
GO TO 32
40 WRITE(JDSK,51)LAST,J,(KMDLTR(I),I=ILEFT,IRIGHT)
GO TO 32
41 WRITE(JDSK,52)LAST,J,(KMDLTR(I),I=ILEFT,IRIGHT)
GO TO 32
42 WRITE(JDSK,53)LAST,J,(KMDLTR(I),I=ILEFT,IRIGHT)
GO TO 32
43 WRITE(JDSK,54)LAST,J,(KMDLTR(I),I=ILEFT,IRIGHT)
GO TO 32
44 WRITE(JDSK,55)LAST,J,(KMDLTR(I),I=ILEFT,IRIGHT)
GO TO 32
45 FORMAT(1HC,23X,1I3,1X,80A1)
46 FORMAT(1HC,1I7,16H NONE NONE ,1I3,1X,80A1)
47 FORMAT(1HC,1I7,16H DYNAMIC INTEGER,1I3,1X,80A1)
48 FORMAT(1HC,1I7,16H WORD INTEGER,1I3,1X,80A1)
49 FORMAT(1HC,1I7,16H NUMBER INTEGER,1I3,1X,80A1)
50 FORMAT(1HC,1I7,16H TEXT INTEGER,1I3,1X,80A1)
51 FORMAT(1HC,1I7,16H DYNAMIC REAL ,1I3,1X,80A1)
52 FORMAT(1HC,1I7,16H WORD REAL ,1I3,1X,80A1)
53 FORMAT(1HC,1I7,16H NUMBER REAL ,1I3,1X,80A1)
54 FORMAT(1HC,1I7,16H TEXT REAL ,1I3,1X,80A1)
55 FORMAT(1HC,1I7,16H PARENTHETICAL ,1I3,1X,80A1)
C
C GENERATE DIMENSION STATEMENTS
56 WRITE(JDSK,57)
57 FORMAT(1HC)
58 IF(IFANY.NE.0)CALL DASAVE(1,3,53,10,KMDTYP,
1KNTCMD,KMDLTR,KNTLTR,KNAME,KLONG,JDSK,IERR)
CALL DASAVE(1,-1,53,10,KMDTYP,
1KNTCMD,KMDLTR,KNTLTR,LNAME,LLONG,JDSK,IERR)
CALL DASAVE(1,3,53,10,KMDWID,
1KNTCMD,KMDLTR,KNTLTR,MNAME,MLONG,JDSK,IERR)
IF(JFANY.NE.0)CALL DASAVE(1,3,53,10,KMDARG,
1KNTCMD,KMDLTR,KNTLTR,NNAME,NLONG,JDSK,IERR)
C
C GENERATE EQUIVALENCE STATEMENTS
WRITE(JDSK,57)
IF(IFANY.NE.0)CALL DASAVE(2,3,53,10,KMDTYP,
1KNTCMD,KMDLTR,KNTLTR,KNAME,KLONG,JDSK,IERR)
CALL DASAVE(2,-1,53,10,KMDTYP,
1KNTCMD,KMDLTR,KNTLTR,LNAME,LLONG,JDSK,IERR)
CALL DASAVE(2,3,53,10,KMDWID,
1KNTCMD,KMDLTR,KNTLTR,MNAME,MLONG,JDSK,IERR)
IF(JFANY.NE.0)CALL DASAVE(2,3,53,10,KMDARG,
1KNTCMD,KMDLTR,KNTLTR,NNAME,NLONG,JDSK,IERR)
C
C GENERATE DATA STATEMENTS
WRITE(JDSK,59)INAME,JNAME,KNTLTR,KNTCMD
59 FORMAT(1HC/36HC NUMBER OF CHARACTERS AND WORDS/
111H DATA ,6A1,1H,6A1,1H/,1I4,1H,,1I4,1H/)
IF(IFANY.EQ.0)GO TO 61
WRITE(JDSK,60)
60 FORMAT(1HC/37HC NUMBER IDENTIFYING EACH COMMAND)
CALL DASAVE(3,3,53,10,KMDTYP,
1KNTCMD,KMDLTR,KNTLTR,KNAME,KLONG,JDSK,IERR)
61 WRITE(JDSK,62)
62 FORMAT(1HC/34HC LETTERS FORMING EACH COMMAND)
CALL DASAVE(3,-1,53,10,KMDTYP,
1KNTCMD,KMDLTR,KNTLTR,LNAME,LLONG,JDSK,IERR)
WRITE(JDSK,63)
63 FORMAT(1HC/28HC LENGTH OF EACH COMMAND)
CALL DASAVE(3,3,53,10,KMDWID,
1KNTCMD,KMDLTR,KNTLTR,MNAME,MLONG,JDSK,IERR)
IF(JFANY.EQ.0)GO TO 65
WRITE(JDSK,64)
64 FORMAT(1HC/27HC TYPE OF ARGUMENT LIST)
CALL DASAVE(3,3,53,10,KMDARG,
1KNTCMD,KMDLTR,KNTLTR,NNAME,NLONG,JDSK,IERR)
65 STOP
C376787486395$'
END