Trailing-Edge
-
PDP-10 Archives
-
decuslib20-05
-
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