Return to SETCOM.f CVS log

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

researchv10 Norman

      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

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