      SUBROUTINE SETCOM(PP, K)
      LOGICAL SYSERR, ERR, ABORT, BLANK
      INTEGER PLAT, DSA, SYMLEN, PP, PDSA, COM, PCOM, R(5), S(3),
     *    FINDND, ST, SS(1), FINDCM
      INTEGER ZERO(1)
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /PARAMS/ INUT, I1, NOCHAR, SYMLEN, I2, I3, I4
      COMMON /COMS/ LCOM, PCOM, COM(300)
C
C     COM ENTRY
C     WORD 1.....PACKED CHARACTERS OF COMMON-NAME
C     WORD 2....TOTAL LENGTH OF COMMON BLOCK
C     WORD 3.....1 IF COMMON INITIALIZED BY BLOCK DATA SUBPGM
C      0 IF NOT
C     WORDS 4-8...TOTAL LENGTHS OF COMPLEX, DOUBLE PRECIS,
C     REAL, INTEGER, LOGICAL DATA TYPES RESPECTIVELY
C     WORD 9.....INDEX IN LAT OF ENTRY OF P.U. WHICH CONTAINS
C     THIS DEFN OF THE COMMON BLOCK
C
C     FINDS COMMON BLOCK ENTRY IN COM- ELSE CREATES AND INITIALIZES NEW
C     ENTRY. CHECKS NEW ENTRY BLOCK NOT ALREADY A SUBPGM NAME.
C     GATHERS INFO ON ORDER, TYPE, LENGTH OF ENTRIES IN THE COMMON-
C     CHECKS FOR VARIABLY DIMENSIONED ARRAYS.
C     FORMS COMMONLIST ENTRY FOR BLOCK OFF SUBPGM AT LAT(PP)
C     IF FOUND COMMON IN COM, COMPARES OLD DEFN TO NEW FOR ORDER, LEN,
C     TYPE OF ENTRIES; FLAGS INCONSISTENCIES; NOTES IF COMMON IN
C     TWO BLOCK DATA PGMS.  COMMON IS AT DSA(K)
C
      DATA R(1), R(4) /2*1/, R(2), R(3), R(5) /3*2/, ST /1H*/
      DATA ZERO(1) /0/
C
C     CHECK ISNT IN NODE AS PROCEDURE NAME
C
      IF (FINDND(DSA(K+4),KK)) 20, 20, 10
   10 CALL ERROR2(41H COMMON BLOCK HAS SAME NAME AS SUBPROGRAM, 41,
     *  DSA(K+4), 1, 1, 1)
C
C     CHECK IF IN COM ALREADY
C
   20 KK = FINDCM(DSA(K+4))
      IF (KK) 30, 30, 60
C
C     CREATE NEW ENTRY
C
   30 IF (PCOM+SYMLEN+5.GT.LCOM) GO TO 260
      DO 40 I=1,SYMLEN
        L = PCOM + I - 1
        LL = K + I + 3
        COM(L) = DSA(LL)
   40 CONTINUE
C
C     MARK COMMON SET WHEN IT IS CREATED BY A BLOCK-DATA
C     SUBPROGRAM WHICH SET IT
C
      DO 50 I=1,4
        LL = L + I
        COM(LL) = 0
   50 CONTINUE
      COM(LL+1) = PP
      IF (IGATT1(NAME,8).EQ.11 .AND. IGATT1(K,2).EQ.1) COM(L+2) = 1
      KK = PCOM
      PCOM = PCOM + SYMLEN + 5
C
C     GATHER INFO ABT LENGTH,TYPE,ORDER OF ELEMENTS
C
   60 L = 0
      S(1) = 0
      S(2) = 0
      S(3) = 0
      I = DSA(K+2)
   70 IF (I) 130, 130, 80
C
C     READING LIST OF ELEMENTS IN COMMON-CHECK TYPE,STRUCTURE
C
   80 K1 = IGATT1(DSA(I),1)
      K2 = IGATT1(DSA(I),7)
      K1 = MOD(K1,8)
      IF (K1.EQ.5) K1 = 2
C
C     R(I) CONTAINS PROPER ORDER OF TYPE I IN DEFN OF COMMON
C
      LL = R(K1+1)
      IF (LL.LT.L) GO TO 120
      IF (K2) 90, 90, 100
   90 S(LL) = S(LL) + 1
      GO TO 110
  100 K2 = DSA(I)
      K2 = DSA(K2+2)
      S(LL) = S(LL) + DSA(K2)
  110 I = DSA(I+1)
      L = LL
      GO TO 70
C
C     ACCUMULATE COUNTS OF TYPES-NOTE TYPES OUT OF ORDER CAUSES
C     TRUNCATION OF THE DEFINITION
C
  120 CALL ERROR2(41H ILLEGAL ORDERING OF DATA-TYPES IN COMMON, 41,
     *  COM(KK), 1, 1, 0)
      CALL ERROR2(1H1, 0, ZERO(1), -1, 0, 1)
  130 S(3) = S(1) + S(2)
C
C     HANG COMMONLIST ENTRY OFF PP NODE, IF NOT ALREADY THERE FROM SET
C
      L = PP + SYMLEN + 2
      I = MATCH(LAT(L),2,-K)
      IF (I.GT.0) GO TO 140
      I = MATCH(LAT(L),2,KK)
      IF (I.LE.0) GO TO 150
  140 LAT(I) = KK
      GO TO 160
C
C     CREATE NEW ENTRY
C
  150 IF (PLAT+3.GT.LLAT) GO TO 280
      LAT(PLAT) = KK
      LAT(PLAT+1) = 0
      LAT(PLAT+2) = LAT(L)
      LAT(L) = PLAT
      PLAT = PLAT + 3
  160 I = KK + SYMLEN
      IF (COM(I)) 170, 170, 190
C
C     NEW DEFN
C
  170 COM(I) = S(3)
      COM(I+2) = S(1)
      COM(I+3) = S(2)
  180 RETURN
C
C     COMPARE LENGTHS OF EACH TYPE
C
  190 L = KK + SYMLEN + 2
      BLANK = .FALSE.
      CALL S5UNPK(COM(KK), SS(1), 1)
      IF (SS(1).EQ.ST) BLANK = .TRUE.
      IBR = 0
      IF (COM(L+1).NE.S(2)) IBR = 1
      IF (COM(L).NE.S(1)) IBR = -1
C     BLANK COMMON DEFNS MATCH
      IF (IBR.EQ.0 .AND. BLANK) GO TO 180
C     NAMED COMMON DEFNS MATCH
      IF (IBR.EQ.0 .AND. .NOT.BLANK) GO TO 210
C     BLANK COMMON DONT MATCH
      IF (IBR.NE.0 .AND. BLANK) GO TO 230
C     NAMED COMMONS DONT MATCH -- ERROR
 200  CALL ERROR2(25H INCOMPATIBLE COMMON DEFN, 25, COM(KK), 1, 1,
     *  0)
      K1 = KK + SYMLEN + 4
      K1 = COM(K1)
      CALL ERROR2(3H IN, 3, LAT(K1), 1, 0, 0)
      CALL ERROR2(4H AND, 4, LAT(PP), 1, 0, 1)
      IF (BLANK) GO TO 180
C
C     CHECK DOUBLE SETTING OF BLOCK
C
  210 IF (IGATT1(K,2).NE.1 .OR. IGATT1(NAME,8).NE.11) GO TO 180
      IF (COM(L-1).NE.1) GO TO 220
      CALL ERROR2(
     *    53H COMMON BLOCK INITIALIZED IN TWO BLOCK DATA SUBPGMS  , 53,
     *  COM(KK), 1, 1, 1)
      GO TO 180
  220 COM(L-1) = 1
      GO TO 180
C
C     CHECK ARE LENGTHENING BLANK COMMON OFF THE END
C
 230  IF(IBR.EQ.(-1)) GOTO 250
C     ARE LENGTHENING OFF END
C     KEEP LONGEST DEFN
      IF (COM(L+1).GT.S(2)) GO TO 180
  240 COM(L+1) = S(2)
      LL = SYMLEN + KK
      COM(LL) = S(3)
      COM(LL+4) = PP
      GO TO 180
C     SEE ARE REALLY LENGTHENING OFF END IF
C     DEFNS DIFFER IN FIRST DATA TYPE AREAS
  250 IF (S(1).LT.COM(L) .AND. S(2).EQ.0) GO TO 180
      IF (.NOT.(S(1).GT.COM(L) .AND. COM(L+1).EQ.0)) GO TO 200
      COM(L) = S(1)
      GO TO 240
  260 CALL ERROR1(33H IN SETCOM, TABLE OVERFLOW OF COM, 33)
  270 SYSERR = .TRUE.
      GO TO 180
  280 CALL ERROR1(33H IN SETCOM, TABLE OVERFLOW OF LAT, 33)
      GO TO 270
      END
