Trailing-Edge
-
PDP-10 Archives
-
decus_20tap5_198111
-
decus/20-0141/daload.for
There are 2 other files named daload.for in the archive. Click here to see a list.
SUBROUTINE DALOAD(IDSK ,LTRMAX,NUMMAX,MAXBFR,LTRUSD,
1NUMUSD,LTRSTR,NUMSTR,IBUFFR,IFULL )
C RENBR(/CONSTRUCT DESCRIPTION OF FORTRAN ARRAYS)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C THIS ROUTINE IS USED ALONG WITH SEVERAL OTHERS IN
C FASP, THE FORTRAN ALPHAMERIC SUBROUTINE PACKAGE, FOR
C THE PURPOSE OF SELECTING BY NAME AND SUBSCRIPTS,
C EXAMINING AND MODIFYING THE VALUES IN ARRAY LOCATIONS
C KNOWN TO THE CALLING PROGRAM. PLEASE CONSULT THE
C FASP DOCUMENTATION FOR DESCRIPTIONS OF THESE ROUTINES
C
DIMENSION LTRSTR(LTRMAX),NUMSTR(NUMMAX),
1IBUFFR(MAXBFR),IDIGIT(10),LETTER(26),ITYPE(26),
2IWORD(42),KNTLTR(8)
DATA KNTLTR/5,7,4,6,9,8,3,0/
DATA IWORD/
11HO,1HC,1HT,1HA,1HL,
21HI,1HN,1HT,1HE,1HG,1HE,1HR,
31HR,1HE,1HA,1HL,
41HC,1HO,1HM,1HM,1HO,1HN,
51HD,1HI,1HM,1HE,1HN,1HS,1HI,1HO,1HN,
61HI,1HM,1HP,1HL,1HI,1HC,1HI,1HT,
71HE,1HN,1HD/
DATA IDIGIT/
11H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
DATA LETTER/
11HA,1HB,1HC,1HD,1HE,1HF,1HG,1HH,1HI,1HJ,
21HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,1HS,1HT,
31HU,1HV,1HW,1HX,1HY,1HZ/
DATA ICOMNT,ILEFT,IRIGHT,IPLUS,IMINUS,ICOMMA,ISLASH,
1ICOLON,IBLANK,ITAB/
21HC,1H(,1H),1H+,1H-,1H,,1H/,1H:,1H ,1H /
C
C DEFINE DEFAULT TYPES BASED ON LEADING LETTERS OF NAME
DO 1 I=1,26
ITYPE(I)=1
1 CONTINUE
DO 2 I=9,14
ITYPE(I)=0
2 CONTINUE
C
C CLEAR OTHER INTERNAL STORAGE
JSLASH=-1
KOUNT=0
IWHERE=0
3 KONTNU=0
C
C READ IN NEXT LINE
4 READ(IDSK,5,END=15)IBUFFR
5 FORMAT(100A1)
IF(IBUFFR(1).EQ.ICOMNT)GO TO 4
C
C FIND RIGHT END OF TEXT
IEND=MAXBFR
GO TO 7
6 IEND=IEND-1
IF(IEND.LE.0)GO TO 4
7 IF(IBUFFR(IEND).EQ.IBLANK)GO TO 6
IF(IBUFFR(IEND).EQ.ITAB)GO TO 6
C
C TEST IF THE LINE IS A CONTINUATION
IF(IBUFFR(1).EQ.IBLANK)GO TO 10
IF(IBUFFR(1).NE.ITAB)GO TO 10
IBGN=1
8 IBGN=IBGN+1
IF(IBUFFR(IBGN).EQ.IBLANK)GO TO 8
IF(IBUFFR(IBGN).EQ.ITAB)GO TO 8
DO 9 I=2,10
IF(IBUFFR(IBGN).EQ.IDIGIT(I))GO TO 16
9 CONTINUE
IF(IBUFFR(IBGN).NE.IDIGIT(1))IBGN=IBGN-1
GO TO 11
10 IF(IEND.LT.6)GO TO 4
IBGN=6
IF(IBUFFR(6).EQ.IBLANK)GO TO 11
IF(IBUFFR(6).EQ.IDIGIT(1))GO TO 11
GO TO 16
C
C START OF NEW STATEMENT, LOOK FOR KNOWN LEADING WORDS
11 IF(KOUNT.NE.0)GO TO 36
12 KONTNU=0
KOUNT=0
IWHERE=0
LAST=0
IF(JSLASH.GT.0)JSLASH=JSLASH-2
13 KONTNU=KONTNU+1
IF(KNTLTR(KONTNU).LE.0)GO TO 3
INIT=LAST+1
LAST=LAST+KNTLTR(KONTNU)
JBGN=IBGN
14 JBGN=JBGN+1
IF(JBGN.GT.IEND)GO TO 13
IF(IBUFFR(JBGN).EQ.IBLANK)GO TO 14
IF(IBUFFR(JBGN).EQ.ITAB)GO TO 14
IF(IBUFFR(JBGN).NE.IWORD(INIT))GO TO 13
INIT=INIT+1
IF(INIT.LE.LAST)GO TO 14
IBGN=JBGN
IF(KONTNU.LT.6)GO TO 17
IF(KONTNU.EQ.6)GO TO 48
IF(JBGN.NE.IEND)GO TO 3
IFULL=1
GO TO 67
C
C END-OF-FILE READ
15 IFULL=2
IF(KONTNU.LE.0)GO TO 67
IF(KOUNT.EQ.0)GO TO 67
IWHERE=-1
GO TO 36
C
C FIND THE NAME IF ANY
16 IF(KONTNU.EQ.0)GO TO 4
I=IWHERE
IWHERE=0
IF(I.EQ.1)GO TO 18
IF(I.EQ.2)GO TO 28
IF(I.EQ.3)GO TO 51
17 KOUNT=0
NUMBGN=NUMUSD
LTRBGN=LTRUSD
INIGOT=0
LMTGOT=0
KBREAK=1
18 IBGN=IBGN+1
IF(IBGN.GT.IEND)GO TO 61
IF(IBUFFR(IBGN).EQ.ISLASH)GO TO 22
IF(IBUFFR(IBGN).EQ.ILEFT)GO TO 25
IF(JSLASH.EQ.2)GO TO 18
IF(IBUFFR(IBGN).EQ.IBLANK)GO TO 18
IF(IBUFFR(IBGN).EQ.ITAB)GO TO 18
DO 19 I=1,26
IF(IBUFFR(IBGN).NE.LETTER(I))GO TO 19
IF(KOUNT.NE.0)GO TO 21
NUMUSD=NUMUSD+3
IF(NUMUSD.GT.NUMMAX)GO TO 64
J=KONTNU-2
IF(J.GT.1)J=ITYPE(I)
NUMSTR(NUMUSD-1)=J
GO TO 21
19 CONTINUE
IF(KOUNT.EQ.0)GO TO 18
DO 20 I=1,10
IF(IBUFFR(IBGN).EQ.IDIGIT(I))GO TO 21
20 CONTINUE
GO TO 36
21 LTRUSD=LTRUSD+1
IF(LTRUSD.GT.LTRMAX)GO TO 65
LTRSTR(LTRUSD)=IBUFFR(IBGN)
KOUNT=KOUNT+1
GO TO 18
C
C SLASH FOUND
22 IF(KOUNT.EQ.0)GO TO 23
IBGN=IBGN-1
GO TO 42
23 IF(JSLASH.LE.0)GO TO 24
JSLASH=JSLASH-2
GO TO 18
24 JSLASH=1
GO TO 18
C
C LEFT PARENTHESIS FOUND
25 IF(KOUNT.NE.0)GO TO 26
IF(JSLASH.EQ.2)GO TO 26
IF(JSLASH.EQ.0)GO TO 26
KOUNT=-1
NUMUSD=NUMUSD+3
IF(NUMUSD.GT.NUMMAX)GO TO 64
C
C EVALUATE SUBSCRIPT RANGES
26 IDONE=0
INIVAL=0
INIGOT=0
LMTGOT=0
27 ISIGN=1
28 IBGN=IBGN+1
IF(IBGN.GT.IEND)GO TO 62
IF(IBUFFR(IBGN).EQ.IBLANK)GO TO 28
IF(IBUFFR(IBGN).EQ.ITAB)GO TO 28
IF(IBUFFR(IBGN).EQ.IRIGHT)GO TO 37
IF(KOUNT.EQ.0)GO TO 28
IF(IBUFFR(IBGN).EQ.ISLASH)GO TO 35
IF(IBUFFR(IBGN).EQ.ICOLON)GO TO 35
IF(IBUFFR(IBGN).EQ.IPLUS)GO TO 32
IF(IBUFFR(IBGN).EQ.IMINUS)GO TO 31
IF(IBUFFR(IBGN).EQ.ICOMMA)GO TO 38
DO 30 I=1,10
IF(IBUFFR(IBGN).NE.IDIGIT(I))GO TO 30
IF(LMTGOT.NE.0)GO TO 29
INIVAL=(10*INIVAL)+I-1
INIGOT=ISIGN
GO TO 28
29 LMTVAL=(10*LMTVAL)+I-1
LMTGOT=ISIGN
GO TO 28
30 CONTINUE
GO TO 28
31 ISIGN=-1
GO TO 33
32 ISIGN=1
33 IF(LMTGOT.NE.0)GO TO 34
IF(INIGOT.NE.0)GO TO 34
INIGOT=ISIGN
GO TO 28
34 LMTGOT=ISIGN
LMTVAL=0
GO TO 28
35 LMTGOT=2
LMTVAL=0
GO TO 27
36 IF(INIGOT.EQ.0)GO TO 42
37 IDONE=1
C
C STORE THE EVALUATED SUBSCRIPT RANGE
38 IF(KOUNT.EQ.0)GO TO 41
IF(INIGOT.EQ.0)INIVAL=1
IF(INIGOT.LT.0)INIVAL=-INIVAL
IF(LMTGOT.NE.0)GO TO 39
LMTVAL=INIVAL
INIVAL=1
GO TO 40
39 IF(LMTGOT.GT.1)LMTVAL=1
IF(LMTGOT.LT.0)LMTVAL=-LMTVAL
40 NUMUSD=NUMUSD+2
IF(NUMUSD.GT.NUMMAX)GO TO 64
NUMSTR(NUMUSD-1)=INIVAL
NUMSTR(NUMUSD)=LMTVAL
LMTVAL=LMTVAL-INIVAL
IF(LMTVAL.LT.0)LMTVAL=-LMTVAL
KBREAK=KBREAK*(LMTVAL+1)
41 IF(IDONE.EQ.0)GO TO 26
C
C DONE WITH THIS SPECIFICATION
42 IF(KOUNT.EQ.0)GO TO 18
J=KOUNT
IF(KOUNT.LT.0)J=0
IF(JSLASH.NE.0)J=-J
NUMSTR(NUMBGN+1)=J
NUMSTR(NUMBGN+3)=(NUMUSD-NUMBGN-3)/2
IF(JSLASH.EQ.0)GO TO 46
IBREAK=NUMBGN+2
IF(JSLASH.GT.0)GO TO 44
JSLASH=0
IF(KOUNT.LT.0)GO TO 45
I=NUMUSD
NUMUSD=NUMUSD+3
IF(NUMUSD.GT.NUMMAX)GO TO 64
43 NUMSTR(I+3)=NUMSTR(I)
I=I-1
IF(I.GT.NUMBGN)GO TO 43
NUMSTR(NUMBGN+1)=0
NUMSTR(NUMBGN+3)=0
NUMSTR(NUMBGN+4)=KOUNT
NUMSTR(IBREAK)=KBREAK
GO TO 47
44 JSLASH=2
45 NUMSTR(IBREAK)=0
GO TO 47
46 NUMSTR(IBREAK)=NUMSTR(IBREAK)+KBREAK
47 IF(IWHERE.EQ.0)GO TO 17
IF(IWHERE.GT.0)GO TO 12
GO TO 67
C
C CHECK FOR LETTERS IN PARENTHESES AFTER IMPLICT
C INIGOT = -3, NEITHER PARENTHESIS NOR TYPE NAME FOUND
C = -2, TYPE NAME BUT NOT PARENTHESIS FOUND
C = -1, PARENTHESIS BUT NOT TYPE NAME FOUND
C = 0, BOTH PARENTHESIS AND TYPE NAME FOUND
C = .GT.0, LOCATION IN ALPHABET OF LETTER IN
C PARENTHESIS AFTER TYPE NAME
48 INIGOT=-3
GO TO 51
49 INIGOT=-2
GO TO 51
50 INIGOT=0
51 IBGN=IBGN+1
IF(IBGN.GT.IEND)GO TO 63
IF(IBUFFR(IBGN).EQ.IBLANK)GO TO 51
IF(IBUFFR(IBGN).EQ.ITAB)GO TO 51
IF(INIGOT.GE.-1)GO TO 52
IF(IBUFFR(IBGN).EQ.ICOMMA)GO TO 51
IF(IBUFFR(IBGN).NE.ILEFT)GO TO 57
INIGOT=INIGOT+2
GO TO 51
52 IF(INIGOT.GE.0)GO TO 53
IF(IBUFFR(IBGN).EQ.IRIGHT)GO TO 48
GO TO 51
53 IF(IBUFFR(IBGN).EQ.IRIGHT)GO TO 49
IF(IBUFFR(IBGN).EQ.ICOMMA)GO TO 50
DO 56 I=1,26
IF(IBUFFR(IBGN).NE.LETTER(I))GO TO 56
IF(INIGOT.NE.0)GO TO 55
INIGOT=I
54 ITYPE(INIGOT)=JTYPE-2
55 IF(INIGOT.GE.I)GO TO 51
INIGOT=INIGOT+1
GO TO 54
56 CONTINUE
GO TO 51
C
C CHECK FOR TYPE NAMES IN IMPLICIT STATEMENT
57 LAST=0
JTYPE=0
58 JTYPE=JTYPE+1
IF(JTYPE.GT.3)GO TO 48
INIT=LAST+1
LAST=LAST+KNTLTR(JTYPE)
JBGN=IBGN
GO TO 60
59 JBGN=JBGN+1
60 IF(JBGN.GT.IEND)GO TO 58
IF(IBUFFR(JBGN).EQ.IBLANK)GO TO 59
IF(IBUFFR(JBGN).EQ.ITAB)GO TO 59
IF(IBUFFR(JBGN).NE.IWORD(INIT))GO TO 58
INIT=INIT+1
IF(INIT.LE.LAST)GO TO 59
IBGN=JBGN
GO TO 49
C
C END OF LINE FOUND WHILE PROCESSING
61 IWHERE=1
GO TO 4
62 IWHERE=2
GO TO 4
63 IWHERE=3
C TYPE 999,LETTER,ITYPE
C 999 FORMAT(2X,26A2/1X,26I2/)
GO TO 4
C
C NUMBER OR CHARACTER STORAGE OVERFLOW
64 IFULL=3
GO TO 66
65 IFULL=4
66 NUMUSD=NUMBGN
LTRUSD=LTRBGN
C
C RETURN TO CALLING PROGRAM
67 RETURN
C JSLASH = -1, PLACE NULL HEADER BEFORE NEXT ITEM
C = 0, BEYOND SLASH PAIR CONTAINING SOMETHING
C = 1, WITHIN A SLASH PAIR BUT NOTHING FOUND
C = 2, WITHIN SLASH PAIR AND SOMTHING FOUND
C IWHERE = 0, END OF LINE AT NONCRITICAL POINT
C = 1, END OF LINE IN FINDING ARRAY NAME
C = 2, END OF LINE IN FINDING SUBSCRIPTS
C = 3, END OF LINE IN IMPLICIT STATEMENT
C903487431491:
END