Google
 

Trailing-Edge - PDP-10 Archives - decus_20tap5_198111 - decus/20-0141/dalone.for
There are 2 other files named dalone.for in the archive. Click here to see a list.
      SUBROUTINE DALONE(LMTTYP,LTRINI,LTRUSD,LTRSTR,NUMINI,
     1    NUMUSD,NUMSTR,KNTSUB,NOWSUB,NAMMAX,NAME  ,NAMUSD)
C     RENBR(/REPRESENT ARRAY NAME AND SUBSCRIPT LIMITS)
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(LTRUSD),NUMSTR(NUMUSD),
     1NAME(NAMMAX),NOWSUB(KNTSUB),ITYPE(16),LTRBGN(4)
      DATA LTRBGN/1,6,13,18/
      DATA ITYPE/
     11HO,1HC,1HT,1HA,1HL,
     21HI,1HN,1HT,1HE,1HG,1HE,1HR,
     31HR,1HE,1HA,1HL/
      DATA ILEFT,IRIGHT,ICOMMA,ISLASH,ISPACE/
     11H(,1H),1H,,1H/,1H /
C
      INITAL=NAMUSD
      LTRGET=LTRINI
      NUMGET=NUMINI+1
      LTRKNT=NUMSTR(NUMINI)
C
C     INSERT NUMBER TYPE OR SIZE OF RECORD
      IF(LMTTYP.GE.-1)GO TO 3
      IVALUE=NUMSTR(NUMINI+1)
      IPART=-1
      IF(LTRKNT.LE.0)GO TO 15
      IVALUE=IVALUE+2
      J=LTRBGN(IVALUE)
      K=LTRBGN(IVALUE+1)-1
      DO 1 I=J,K
      IF(NAMUSD.GE.NAMMAX)GO TO 17
      NAMUSD=NAMUSD+1
      NAME(NAMUSD)=ITYPE(I)
    1 CONTINUE
    2 IF(NAMUSD.GE.NAMMAX)GO TO 17
      NAMUSD=NAMUSD+1
      NAME(NAMUSD)=ISPACE
C
C     INSERT ARRAY NAME INTO OUTPUT BUFFER
    3 IF(LTRKNT.LT.0)LTRKNT=-LTRKNT
    4 IF(LTRKNT.LE.0)GO TO 5
      IF(NAMUSD.GE.NAMMAX)GO TO 17
      NAMUSD=NAMUSD+1
      IF(LTRGET.GT.LTRUSD)GO TO 17
      NAME(NAMUSD)=LTRSTR(LTRGET)
      LTRGET=LTRGET+1
      LTRKNT=LTRKNT-1
      GO TO 4
C
C     INSERT SUBSCRIPT LIMITS INTO OUTPUT BUFFER
    5 IF(LMTTYP.LE.0)GO TO 6
      MAXSUB=1
      GO TO 7
    6 MAXSUB=NUMSTR(NUMINI+2)
      IF(MAXSUB.LE.0)GO TO 18
    7 IF(NAMUSD.GE.NAMMAX)GO TO 17
      NAMUSD=NAMUSD+1
      NAME(NAMUSD)=ILEFT
      NEWSUB=0
    8 NEWSUB=NEWSUB+1
      IF(NEWSUB.GT.MAXSUB)GO TO 16
      IF(LMTTYP.LT.0)GO TO 10
      IF(LMTTYP.EQ.0)GO TO 9
      IVALUE=LMTTYP
      GO TO 14
    9 IVALUE=NOWSUB(NEWSUB)
      GO TO 14
   10 NUMGET=NUMGET+2
      IF(NUMSTR(NUMGET+1).LE.0)GO TO 11
      IF(NUMSTR(NUMGET).EQ.1)GO TO 13
   11 IVALUE=NUMSTR(NUMGET)
      IPART=0
      GO TO 15
   12 IF(NAMUSD.GE.NAMMAX)GO TO 17
      NAMUSD=NAMUSD+1
      NAME(NAMUSD)=ISLASH
   13 IVALUE=NUMSTR(NUMGET+1)
   14 IPART=1
   15 LFTCOL=NAMUSD
      CALL DANUMB(0,IVALUE,10,NAME,NAMUSD,LFTCOL,NAMMAX)
      IF(NAMUSD.EQ.LFTCOL)GO TO 17
      IF(NAMUSD.GE.NAMMAX)GO TO 17
      IF(IPART.EQ.0)GO TO 12
      IF(IPART.LT.0)GO TO 2
      NAMUSD=NAMUSD+1
      NAME(NAMUSD)=ICOMMA
      GO TO 8
   16 NAME(NAMUSD)=IRIGHT
      GO TO 18
C
C     RETURN TO CALLING PROGRAM
   17 NAMUSD=INITAL
   18 RETURN
C590391099687
      END