Google
 

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