V10/cmd/pfort/COMMON.f

      SUBROUTINE COMMON
      INTEGER PSTMT, PDSA, STMT, DSA, BNEXT, SYMHD, S(4)
      LOGICAL ERR, SYSERR, ABORT, ARDECL
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      DATA S(1) /66/, S(2) /32/, S(3) /44/, S(4) /42/
C
C     PROCESSES A COMMON STMT
C     FIRST, PEEL OFF NAME OF COMMON AND SET SYMBOL TABLE ENTRY USAGE
C     CHECK NAME HAS NOT APPEARED BEFORE IN PGM UNIT
C
      IF (STMT(PSTMT).EQ.67) GO TO 30
C
C     SET SYMBOL TABLE ENTRY FOR BLANK COMMON
C
   10 I1 = IGATT1(NAME,8)
      IF (I1.EQ.11) GO TO 170
      IF (PSTMT.GE.NSTMT) GO TO 200
      L = PSTMT
      DO 20 I1=1,4
        STMT(I1) = S(I1)
   20 CONTINUE
      PSTMT = 1
      KK = LOOKUP(5,.FALSE.)
      IF (SYSERR) GO TO 190
      PSTMT = L
      CALL SATT1(KK, 8, 7)
      GO TO 60
   30 PSTMT = PSTMT + 1
      IF (STMT(PSTMT).NE.67) GO TO 40
      PSTMT = PSTMT + 1
      GO TO 10
   40 IF (PSTMT.GE.NSTMT) GO TO 200
      CALL NEXTOK(PSTMT, K2, L)
      IF (L.NE.0) GO TO 200
      KK = LOOKUP(K2,.FALSE.)
      IF (SYSERR) GO TO 190
      I1 = IGATT1(KK,1)
      N = IGATT1(KK,8)
      IF (I1.EQ.0 .AND. (N.EQ.0 .OR. N.EQ.7)) GO TO 50
      CALL ERROR1(20H ILLEGAL COMMON NAME, 20)
      GO TO 190
   50 CALL SATT1(KK, 8, 7)
      I1 = IGATT1(NAME,8)
      IF (I1.EQ.11) CALL SATT1(KK, 2, 1)
      PSTMT = K2 + 1
      IF (PSTMT.GE.NSTMT .OR. STMT(K2).NE.67) GO TO 200
C
C     ELEMENTS IN COMMON: ARRAYS,VARIABLES,DECLARATIONS OF ARRAYS( NOT
C     VARIABLY DIMENSIONED). IMPLICITLY TYPE THEM
C
   60 IF (ARDECL(K2,N)) GO TO 70
      CALL ERROR1(47H COMMON ELEMENT NOT VARIABLE, ARRAY, DECLARATOR,
     *    47)
      GO TO 190
   70 IF (SYSERR .OR. ERR) GO TO 190
C
C     SET SYMBOL TABLE ENTRY OF ELEMENT TO SHOW ITS IN COMMON
C     PUT POINTER TO COMMON NAME INTO 3D WORD OF ENTRY (OR OFF 3D
C     WORD--FOR ARRAYS
C
      I1 = IGATT1(N,2)
      IF (I1.NE.0) GO TO 160
      CALL SATT1(N, 2, 1)
      I1 = IGATT1(N,7)
      IF (I1.EQ.0) GO TO 80
      L = DSA(N+2)
      DSA(L+1) = KK
      GO TO 90
   80 CALL SATT1(N, 8, 10)
      IF (NEXT+2.GE.BNEXT) GO TO 180
      DSA(N+2) = NEXT
      DSA(NEXT) = 0
      DSA(NEXT+1) = KK
      NEXT = NEXT + 2
C
C     SETUP CHAIN OF ELEMENTS OF COMMON HANGING OFF SYMBOL TABLE
C     ENTRY OF COMMON NAME
C
   90 IF (DSA(KK+2).EQ.0) GO TO 130
      L = DSA(KK+2)
  100 IF (DSA(L+1).EQ.0) GO TO 110
      L = DSA(L+1)
      GO TO 100
  110 IF (NEXT+2.GE.BNEXT) GO TO 180
      DSA(L+1) = NEXT
  120 DSA(NEXT) = N
      DSA(NEXT+1) = 0
      NEXT = NEXT + 2
      GO TO 140
  130 IF (NEXT+2.GE.BNEXT) GO TO 180
      DSA(KK+2) = NEXT
      GO TO 120
C
C     CHECK FOR END OF STMT
C
  140 IF (K2.EQ.NSTMT) GO TO 190
      IF (STMT(K2).NE.68) GO TO 150
      PSTMT = K2 + 1
      GO TO 60
  150 IF (STMT(K2).NE.67) GO TO 200
      PSTMT = K2
      GO TO 30
  160 CALL ERROR1(23H ELEMENT IN TWO COMMONS, 23)
      GO TO 140
  170 CALL ERROR1(
     *    51H BLANK COMMON NOT ALLOWED IN BLOCK DATA SUBPROGRAMS, 51)
      GO TO 190
  180 SYSERR = .TRUE.
      CALL ERROR1(33H IN COMMON, TABLE OVERFLOW OF DSA,33)
  190 RETURN
  200 CALL ERROR1(15H ILLEGAL SYNTAX, 15)
      GO TO 190
      END