Trailing-Edge
-
PDP-10 Archives
-
decuslib10-08
-
43,50476/dabase.for
There are 2 other files named dabase.for in the archive. Click here to see a list.
SUBROUTINE DABASE(LOCATE,LTRLFT,LTRRIT,LTRNAM,IVALUE,
1 LTRLOW,LTRUSD,LTRSTR,NUMLOW,NUMUSD,NUMSTR,LRGLTR,
2 LRGNUM,LRGKNT)
C RENBR(/LOCATE START OF LOGICAL GROUP DESCRIPTION)
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 LTRNAM(LTRRIT),LTRSTR(LTRUSD),
1NUMSTR(NUMUSD)
C
LRGLTR=LTRLOW
LRGNUM=NUMLOW
LRGKNT=0
IF(LOCATE.GE.0)GO TO 1
LTRSIZ=LTRRIT-LTRLFT+1
IF(LTRSIZ.EQ.0)LTRSIZ=-1
C
C OBTAIN NUMBER OF LETTERS AND NUMBERS IN ITEM STORAGE
1 IF(LRGNUM.GE.NUMUSD)GO TO 6
IF(NUMSTR(LRGNUM+2).LT.0)GO TO 6
KNTLTR=NUMSTR(LRGNUM)
KNTNUM=3+(2*NUMSTR(LRGNUM+2))
IF(KNTLTR.GT.0)GO TO 5
C
C START OF LOGICAL GROUP FOUND
LRGKNT=LRGKNT+1
KNTLTR=-KNTLTR
IF(LOCATE.GT.0)GO TO 3
IF(LOCATE.EQ.0)GO TO 4
C
C TEST IF NAME MATCHES THAT OF LOGICAL GROUP
IF(KNTLTR.NE.LTRSIZ)GO TO 5
ITEST=LRGLTR
JTEST=LTRLFT
2 IF(LTRSTR(ITEST).NE.LTRNAM(JTEST))GO TO 5
ITEST=ITEST+1
JTEST=JTEST+1
IF(JTEST.LE.LTRRIT)GO TO 2
GO TO 7
C
C TEST IF SUBSCRIPT BOUND HAS PROPER VALUE
3 IF(KNTNUM.LT.(LOCATE+3))GO TO 5
ITEST=LRGNUM+2+LOCATE
IF(NUMSTR(ITEST).EQ.IVALUE)GO TO 7
GO TO 5
C
C CHECK FOR LRGKNT EQUAL TO IVALUE
4 IF(LRGKNT.EQ.IVALUE)GO TO 7
C
C ADVANCE BEYOND CURRENT ITEM IN DICTIONARY
5 LRGLTR=LRGLTR+KNTLTR
LRGNUM=LRGNUM+KNTNUM
GO TO 1
C
C NO MATCH FOUND
6 LRGKNT=0
C
C RETURN TO CALLING PROGRAM
7 RETURN
C317478262830
END