Google
 

Trailing-Edge - PDP-10 Archives - decus_20tap5_198111 - decus/20-0141/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