V10/cmd/pfort/SETNOD.f

      SUBROUTINE SETNOD
      INTEGER PLAT, COM, PNODE, PDSA, DSA, SYMLEN, PP, SYMHD, PCOM,
     *    SETARG, FINDND, FINDCM
      LOGICAL ERR, SYSERR, ABORT
      COMMON /COMS/ LCOM, PCOM, COM(300)
      COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
      COMMON /HEAD/ LNODE, PNODE, NODE(500)
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /PARAMS/ INUT, I1, NOCHAR, SYMLEN, I2, I3, I4
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      COMMON /TABL/ NEXT, LABHD, SYMHD, IBNEXT
      COMMON /SCR1/ LINODE, INODE(500)
C
C     LAT-IS THE CALLING GRAPH PLUS AUXILIARY NODES
C     PLAT-IS NEXT FREE WORD IN LAT
C     LLAT-IS LENGTH OF LAT
C     NODE-IS LIST OF ALL CALLING NODES INDICES IN LAT
C        (WILL BE IN ALPHABETIC ORDER BEFORE CHECKING COMMENCES)
C     PNODE-IS NEXT FREE WORD IN NODE
C     LNODE-IS LENGTH OF NODE
C
C     P.U. NODE IN LAT
C     WD 1.....PACKED CHARACTERS OF NAME OF SUBPGM
C     WD2.....NUMBER OF ARGS
C     WD3.....PTR TO HEAD OF LINEAR LINKED ORDERED LIST OF
C     ARGUMENT NODES IN LAT
C     WD4.....PTR TO HEAD OF LINEAR LINKED LIST OF COMMON NODES
C     IN LAT
C     WD5.....PTR TO HEAD OF LINEAR LINKED LIST OF INDICES IN
C     LAT OF ENTRIES FOR PARENT NODES
C     WD6.....PTR TO HEAD OF LINEAR LINKED LIST OF INDICES IN
C     LAT OF ENTRIES FOR DESCENDENT NODES
C     WD7.....PTR TO HEAD OF LINEAR LINKED LIST OF SEQUENCE NOS OF
C     BAD REFERENCES;  INCONSISTANT TYPE OF FCN/SUBR REFERENCE, INCORR
C     NUMBER OF ARGS, AND RECURSIVE CALL OF SELF ARE THE THREE
C     TYPES OF BAD REFS
C     WD8.....BITS 0-2 TYPE OF SUBPGM:  0 SUBR, 1 FCN, 2 BLOCK DATA,
C      3 MAIN, 4 ASF, 5 SUPEROOT
C     BITS 3-5 (IF FCN OR ASF) CONTAIN TYPE OF FCN: 0 DP, 1 RL,
C     2 INT, 3 COMP, 4 LOG
C
C     ARGUMENT NODE IN LAT
C     WD1.....ATTRIBUTES (SAME AS IN DSA, SEE LOOKUP)
C     WD2.....LENGTH (IN PROCEDURE ARGS THIS WORD POINTS TO
C     HEAD OF LINEAR LINKED LIST OF ACTUAL SUBPGM NAMES ASSOCIATED
C     WITH THIS ARG IN THE PROGRAM; ALSO HAVE INDEX IN LAT OF
C     SUBPRGM IN WHICH THE ASSOC OCCURS
C     WD 3.....PTR TO HEAD OF LINEAR LINKED LIST OF PARENT ARGS
C     (ARGS FROM PARENT RTNES SENT DOWN TO BE ASSOC. WITH THIS ARG)
C     WD 4.....PTR TO HEAD OF LINEAR LINKED LIST OF DESC. ARGS
C     (ARGS FROM DESC RTNES WHICH THIS ARG IS ASSOC. WITH)
C     WD 5.....PTR TO NEXT ARG NODE OR 0
C
C     COMMON NODE IN LAT
C     WD 1.....INDEX OF ENTRY FOR THIS COMMON IN COM
C     WD 2.....1 IF COMMON STORED INTO BY THIS P.U. ELSE 0
C     WD 3.....PTR TO NEXT COMMON NODE
C     CREATE NODE PTR TO NEW NODE IN LAT
C
      IF (PNODE.GT.LNODE) GO TO 170
      IF (PLAT+SYMLEN+7.GT.LLAT) GO TO 190
C
C     CHECK IF SUBPROGRAM HAS NAME SAME AS ANOTHER SUBPROGRAM
C     OR A COMMON BLOCK
C
      II = IGATT1(NAME,8)
      IF (II.EQ.11) GO TO 10
      IF (FINDND(DSA(NAME+4),IROOT)) 10, 10, 20
   10 IF (FINDCM(DSA(NAME+4))) 40, 40, 30
   20 ERR = .TRUE.
   30 CALL ERROR2(45H SUBPROGRAM AND/OR COMMON BLOCK NAME CONFLICT, 45,
     *  DSA(NAME+4), 1, 1, 1)
      IF (.NOT.ERR) GO TO 40
      ERR = .FALSE.
      ABORT = .TRUE.
      GO TO 160
   40 NODE(PNODE) = PLAT
      IROOT = PNODE
      PNODE = PNODE + 1
C
C     ENTER NAME INTO NODE
C
      DO 50 I=1,SYMLEN
        L = NAME + 3 + I
        LL = PLAT - 1 + I
        LAT(LL) = DSA(L)
   50 CONTINUE
C
C     PP POINTS TO CURRENT RTNE NODE IN LAT
C
      PP = PLAT
      PLAT = LL + 6
      LL = LL + 1
      DO 60 I=LL,PLAT
        LAT(I) = 0
   60 CONTINUE
C
C     0 SUBR, 1 FCN, 2 BLOCK DATA, 3 MAIN, 4 ASF, 5 SUPEROOT
C
      LAT(PLAT+1) = II/4
C     INITIALIZE LEVEL OF BLOCK DATA TO -2
      IF (LAT(PLAT+1).EQ.2) INODE(IROOT) = -2
      IF (LAT(PLAT+1).NE.1) GO TO 70
      L = IGATT1(NAME,1)
      LAT(PLAT+1) = LAT(PLAT+1) + 8*MOD(L,8)
   70 PLAT = PLAT + 2
C
C     HAVING INITIALIZED NODE TO 0, LOOK FOR ARGS
C
      IF (DSA(NAME+2)) 80, 90, 80
   80 L = PP + SYMLEN
      LAT(L) = SETARG(PP,NAME)
      IF (SYSERR) GO TO 160
C
C     READ THROUGH SYMBOL TABLE FOR COMMON BLOCK DEFNS AND ASF DEFS
C     AND SETTING OF COMMON REGION
C
   90 K = SYMHD
  100 IF (K) 110, 160, 110
  110 LL = IGATT1(K,8)
C
C     CHECK FOR ASF AND COMMON DEFNS OR COMMON
C     SETTING INFO
C
      GO TO (140, 120, 140, 140, 140, 140, 130, 150, 140, 150, 140,
     *    140, 140, 140), LL
C
C     CREATE ASF NODE
C
  120 CALL SETASF(PP, K)
      IF (SYSERR) GO TO 160
      GO TO 140
C
C     CREATE COM ENTRY
C
  130 CALL SETCOM(PP, K)
      IF (SYSERR) GO TO 160
  140 K = DSA(K+3)
      GO TO 100
C
C     CHECK IF ELEMENT IN COMMON
C
  150 LL = IGATT1(K,2)
      L = IGATT1(K,5)
      IF (L.NE.1 .OR. LL.NE.1) GO TO 140
      L = DSA(K+2)
      L = DSA(L+1)
      CALL MKCOM(PP, L)
      IF (SYSERR) GO TO 160
      GO TO 140
  160 RETURN
  170 CALL ERROR1(34H IN SETNOD, TABLE OVERFLOW OF NODE, 34)
  180 SYSERR = .TRUE.
      GO TO 160
  190 CALL ERROR1(33H IN SETNOD, TABLE OVERFLOW OF LAT, 33)
      GO TO 180
      END