Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-05 - decus/20-0141/dapick.for
There are 2 other files named dapick.for in the archive. Click here to see a list.
      SUBROUTINE DAPICK(MAXBFR,IBUFFR,LTRLOW,LTRUSD,LTRSTR,
     1    NUMLOW,NUMUSD,NUMSTR,MAXSUB,LOWBFR,KIND  ,LRGLTR,
     2    LRGNUM,LRGKNT,INITAL,KOUNT ,LTRINI,NUMINI,KNTSUB,
     3    INISUB,LMTSUB)
C     RENBR(/IDENTIFY ARRAY NAME AND SUBSCRIPT RANGE)
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 IBUFFR(MAXBFR),LTRSTR(LTRUSD),
     1NUMSTR(NUMUSD),INISUB(MAXSUB),LMTSUB(MAXSUB),
     2IDIGIT(10)
      DATA IEQUAL,ILEFT,IRIGHT,IPLUS,IMINUS,ICOMMA,ISLASH,
     1ICOLON,KOMENT,IAND,IEND,IBLANK,ITAB/1H=,1H(,1H),1H+,
     21H-,1H,,1H/,1H:,1H!,1H&,1H;,1H ,1H	/
      DATA IDIGIT/
     11H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
C
C     FIND FIRST AND FINAL NON-BLANK CHARACTERS READ
      KNTSUB=0
      LTREND=LOWBFR
      NEEDED=KIND
      KONTNU=KIND
      GO TO 2
    1 LTREND=LTREND+1
    2 IF(LTREND.GT.MAXBFR)GO TO 5
      IF(IBUFFR(LTREND).EQ.KOMENT)GO TO 5
      IF(IBUFFR(LTREND).NE.IAND)GO TO 1
      KONTNU=0
      GO TO 5
    3 NEEDED=0
    4 LOWBFR=LOWBFR+1
    5 IF(LOWBFR.GE.LTREND)GO TO 47
      IF(IBUFFR(LOWBFR).EQ.IBLANK)GO TO 4
      IF(IBUFFR(LOWBFR).EQ.ITAB)GO TO 4
      IF(IBUFFR(LOWBFR).EQ.IEND)GO TO 3
      IF(NEEDED.GT.0)GO TO 52
    6 LTREND=LTREND-1
      IF(LTREND.LE.LOWBFR)GO TO 7
      IF(IBUFFR(LTREND).EQ.IBLANK)GO TO 6
      IF(IBUFFR(LTREND).EQ.ITAB)GO TO 6
C
C     TEST IF ARRAY NAME APPEARS IN DICTIONARY
    7 NUMNXT=NUMLOW
      LTRNXT=LTRLOW
      LRGKNT=0
    8 NUMINI=NUMNXT
      LTRINI=LTRNXT
      IF(NUMINI.GT.NUMUSD)GO TO 51
      LTRKNT=NUMSTR(NUMINI)
      NEEDED=NUMSTR(NUMINI+2)
      NUMNXT=NUMNXT+3+NEEDED+NEEDED
      IF(LTRKNT.GT.0)GO TO 9
      LTRNXT=LTRNXT-LTRKNT
      INITAL=1
      KOUNT=0
      LRGKNT=LRGKNT+1
      LRGNUM=NUMINI
      LRGLTR=LTRINI
      GO TO 8
    9 LTRNXT=LTRNXT+LTRKNT
      IF(LRGKNT.LE.0)GO TO 8
      NXTBFR=LOWBFR
      LTRLOC=LTRINI
      KOUNT=KOUNT+1
   10 IF(LTRSTR(LTRLOC).NE.IBUFFR(NXTBFR))GO TO 13
      LTRLOC=LTRLOC+1
   11 NXTBFR=NXTBFR+1
      IF(NXTBFR.GT.LTREND)GO TO 12
      IF(IBUFFR(NXTBFR).EQ.IBLANK)GO TO 11
      IF(IBUFFR(NXTBFR).EQ.ITAB)GO TO 11
      IF(LTRLOC.LT.LTRNXT)GO TO 10
      IF(IBUFFR(NXTBFR).EQ.IEND)GO TO 43
      IF(IBUFFR(NXTBFR).EQ.IEQUAL)GO TO 44
      IF(IBUFFR(NXTBFR).EQ.ILEFT)GO TO 16
      GO TO 13
   12 IF(LTRLOC.GE.LTRNXT)GO TO 43
C
C     COMPUTE ARRAY SIZE AND ADD TO OFFSET IF NOMATCH
   13 ISIZE=1
      NUMINI=NUMINI+1
   14 IF(NEEDED.LE.0)GO TO 15
      NUMINI=NUMINI+2
      I=NUMSTR(NUMINI+1)-NUMSTR(NUMINI)
      IF(I.LT.0)I=-I
      ISIZE=ISIZE*(I+1)
      NEEDED=NEEDED-1
      GO TO 14
   15 INITAL=INITAL+ISIZE
      GO TO 8
C
C     FIND USER INDICATED SUBSCRIPTS
   16 KIND=1
      LOWBFR=NXTBFR
      IDONE=0
      INDEX=NUMINI+1
   17 INIVAL=0
      INIGOT=0
      LMTGOT=0
   18 ISIGN=1
   19 IF(LOWBFR.GE.LTREND)GO TO 28
      LOWBFR=LOWBFR+1
      LETTER=IBUFFR(LOWBFR)
      IF(LETTER.EQ.IBLANK)GO TO 19
      IF(LETTER.EQ.ITAB)GO TO 19
      IF(LETTER.EQ.IRIGHT)GO TO 28
      IF(LETTER.EQ.ISLASH)GO TO 26
      IF(LETTER.EQ.ICOLON)GO TO 26
      IF(LETTER.EQ.IPLUS)GO TO 23
      IF(LETTER.EQ.IMINUS)GO TO 22
      IF(LETTER.EQ.ICOMMA)GO TO 29
      IF(LETTER.EQ.IEQUAL)GO TO 27
      IF(LETTER.EQ.IEND)GO TO 27
      DO 21 I=1,10
      IF(LETTER.NE.IDIGIT(I))GO TO 21
      IF(LMTGOT.NE.0)GO TO 20
      INIVAL=(10*INIVAL)+I-1
      INIGOT=ISIGN
      GO TO 19
   20 LMTVAL=(10*LMTVAL)+I-1
      LMTGOT=ISIGN
      GO TO 19
   21 CONTINUE
      GO TO 19
   22 ISIGN=-1
      GO TO 24
   23 ISIGN=1
   24 IF(LMTGOT.NE.0)GO TO 25
      IF(INIGOT.NE.0)GO TO 25
      INIGOT=ISIGN
      GO TO 19
   25 LMTGOT=ISIGN
      LMTVAL=0
      GO TO 19
   26 LMTGOT=2
      LMTVAL=0
      GO TO 18
   27 LOWBFR=LOWBFR-1
   28 IDONE=1
C
C     STORE THE EVALUATED SUBSCRIPT RANGE
   29 IF(KNTSUB.GE.MAXSUB)GO TO 37
      INDEX=INDEX+2
      IF(INIGOT.NE.0)GO TO 32
      IF(INDEX.GE.NUMNXT)GO TO 30
      INIVAL=NUMSTR(INDEX)
      GO TO 31
   30 INIVAL=1
   31 IF(LMTGOT.NE.0)GO TO 33
      GO TO 34
   32 IF(INIGOT.LT.0)INIVAL=-INIVAL
      IF(LMTGOT.NE.0)GO TO 33
      LMTVAL=INIVAL
      GO TO 36
   33 IF(LMTGOT.GT.1)GO TO 34
      IF(LMTGOT.LT.0)LMTVAL=-LMTVAL
      GO TO 36
   34 IF(INDEX.GE.NUMNXT)GO TO 35
      LMTVAL=NUMSTR(INDEX+1)
      GO TO 36
   35 LMTVAL=1
   36 KNTSUB=KNTSUB+1
      INISUB(KNTSUB)=INIVAL
      LMTSUB(KNTSUB)=LMTVAL
   37 IF(IDONE.EQ.0)GO TO 17
C
C     CHECK FOR EQUALS SIGN RIGHT OF SUBSCRIPTS
   38 LOWBFR=LOWBFR+1
      IF(LOWBFR.GT.LTREND)GO TO 39
      IF(IBUFFR(LOWBFR).EQ.IBLANK)GO TO 38
      IF(IBUFFR(LOWBFR).EQ.ITAB)GO TO 38
      IF(IBUFFR(LOWBFR).NE.IEQUAL)GO TO 39
      KIND=2
      LOWBFR=LOWBFR+1
C
C     CHECK SUBSCRIPT RANGES
   39 IF(NEEDED.NE.KNTSUB)GO TO 42
      IF(NEEDED.EQ.0)GO TO 53
      INDEX=NUMINI+1
      DO 41 I=1,NEEDED
      INDEX=INDEX+2
      IF(NUMSTR(INDEX).GT.NUMSTR(INDEX+1))GO TO 40
      IF(INISUB(I).LT.NUMSTR(INDEX))GO TO 50
      IF(INISUB(I).GT.NUMSTR(INDEX+1))GO TO 50
      IF(LMTSUB(I).LT.NUMSTR(INDEX))GO TO 50
      IF(LMTSUB(I).GT.NUMSTR(INDEX+1))GO TO 50
      GO TO 41
   40 IF(INISUB(I).GT.NUMSTR(INDEX))GO TO 50
      IF(INISUB(I).LT.NUMSTR(INDEX+1))GO TO 50
      IF(LMTSUB(I).GT.NUMSTR(INDEX))GO TO 50
      IF(LMTSUB(I).LT.NUMSTR(INDEX+1))GO TO 50
   41 CONTINUE
      GO TO 53
C
C     UNEQUAL NUMBER OF SUBSCRIPTS
   42 IF(NEEDED.NE.0)GO TO 49
      IF(KNTSUB.NE.1)GO TO 49
      IF(INISUB(1).NE.1)GO TO 49
      IF(LMTSUB(1).NE.1)GO TO 49
      GO TO 53
C
C     NO SUBSCRIPTS TYPED BY USER, CHECK IF UNDIMENSIONED
   43 KIND=1
      LOWBFR=NXTBFR
      GO TO 45
   44 KIND=2
      LOWBFR=NXTBFR+1
   45 IF(NEEDED.EQ.0)GO TO 46
      IF(NEEDED.GT.1)GO TO 49
      IF(NUMSTR(NUMINI+3).NE.1)GO TO 49
      IF(NUMSTR(NUMINI+4).NE.1)GO TO 49
   46 KNTSUB=1
      INISUB(1)=1
      LMTSUB(1)=1
      GO TO 53
C
C     RETURN TO CALLING PROGRAM
   47 LOWBFR=MAXBFR+1
      IF(KONTNU.GE.0)GO TO 48
      KIND=3
      GO TO 53
   48 KIND=4
      GO TO 53
   49 KIND=5
      GO TO 53
   50 KIND=6
      GO TO 53
   51 KIND=7
      GO TO 53
   52 KIND=8
   53 RETURN
C502952324441:!&;
      END