Return to SETARG.f CVS log

Up to [Research Unix] / researchv10no / cmd / pfort

researchv10 Norman

      INTEGER FUNCTION SETARG(PP, N)
      INTEGER PLAT, DSA, PP, SYMLEN, PDSA
      LOGICAL ERR, SYSERR, ABORT
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
      COMMON /PARAMS/ INUT, I1, NOCHAR, SYMLEN, I2, I3, I4
C
C     SETS UP LIST OF ARGUMENTS , HANGING OFF NODE AT LAT(PP)
C     ARGES ARE KEPT IN ORDERED LINEAR LINKED LIST
C     ORDERING CORRESPONDS TO LEFT TO RIGHT APPEARENCE IN DEFN
C     N-SUBPRGM ENTRY IN DSA
C     PP- CURRENT RTNE NODE IN LAT
C     ARGUMENT NODE
C     WD 1      ATTRIBUTES
C     WD2       LENGTH WITH -1 FOR VARIABLEY DIMENSIONED ARRAYS
C     WD3       HEAD OF PARENT REFS LIST
C     WD4       HEAD OF DESCENDENTS REFS LIST
C     WD5       PTR TO NEXT ARG
C
C     FIND FIRST ARGUMENT & ZERO COUNT
C
      J = DSA(N+2)
      SETARG = 0
      IPROC = 0
C
C     FIND FIRST ENTRY ON DSA ARGLIST;
C     KK HEAD OF TO BE CREATED ARGLIST IN LAT
C
      I = DSA(J)
      KK = PP + SYMLEN + 1
C
C     SETUP STORAGE FOR ARG ENTRY
C
   10 IF (PLAT+4.GE.LLAT) GO TO 80
C
C     ENTER ATTRIBUTE WORD AND ZERO REST OF ENTRY
C
      LAT(PLAT) = DSA(I)
      LAT(KK) = PLAT
      KK = PLAT + 3
      DO 20 IA=1,3
        L = IA + PLAT
        LAT(L) = 0
   20 CONTINUE
      K = IGATT1(I,8)
      IF (K.NE.10) GO TO 50
C
C     GET STRUCTURE  OF ARG
C
      K = IGATT1(I,7)
      IF (K) 40, 40, 30
C
C     ARRAY
C
   30 K = DSA(I+2)
      LAT(PLAT+1) = DSA(K)
      GO TO 60
C
C     SCALAR
C
   40 LAT(PLAT+1) = 1
      GO TO 60
C     SET RELATIVE ORDER OF PROC ARGS IN ITS 2ND WORD
   50 IPROC = IPROC + 1
      LAT(PLAT+1) = IPROC
C
C     CHECK FOR MORE ARGS; ADVANCE  PLAT
C
   60 PLAT = PLAT + 4
      SETARG = SETARG + 1
      IF (DSA(J+1)) 90, 90, 70
   70 J = DSA(J+1)
      I = DSA(J)
      GO TO 10
   80 SYSERR = .TRUE.
      CALL ERROR1(33H IN SETARG, TABLE OVERFLOW OF LAT, 33)
   90 RETURN
      END

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.