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