![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to SETCOM.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / pfort|
Return to SETCOM.f CVS log | Up to [Research Unix] / researchv10no / cmd / pfort |
1.1 ! root 1: SUBROUTINE SETCOM(PP, K) ! 2: LOGICAL SYSERR, ERR, ABORT, BLANK ! 3: INTEGER PLAT, DSA, SYMLEN, PP, PDSA, COM, PCOM, R(5), S(3), ! 4: * FINDND, ST, SS(1), FINDCM ! 5: INTEGER ZERO(1) ! 6: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 7: COMMON /GRAPH/ LLAT, PLAT, LAT(6000) ! 8: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 9: COMMON /DETECT/ ERR, SYSERR, ABORT ! 10: COMMON /PARAMS/ INUT, I1, NOCHAR, SYMLEN, I2, I3, I4 ! 11: COMMON /COMS/ LCOM, PCOM, COM(300) ! 12: C ! 13: C COM ENTRY ! 14: C WORD 1.....PACKED CHARACTERS OF COMMON-NAME ! 15: C WORD 2....TOTAL LENGTH OF COMMON BLOCK ! 16: C WORD 3.....1 IF COMMON INITIALIZED BY BLOCK DATA SUBPGM ! 17: C 0 IF NOT ! 18: C WORDS 4-8...TOTAL LENGTHS OF COMPLEX, DOUBLE PRECIS, ! 19: C REAL, INTEGER, LOGICAL DATA TYPES RESPECTIVELY ! 20: C WORD 9.....INDEX IN LAT OF ENTRY OF P.U. WHICH CONTAINS ! 21: C THIS DEFN OF THE COMMON BLOCK ! 22: C ! 23: C FINDS COMMON BLOCK ENTRY IN COM- ELSE CREATES AND INITIALIZES NEW ! 24: C ENTRY. CHECKS NEW ENTRY BLOCK NOT ALREADY A SUBPGM NAME. ! 25: C GATHERS INFO ON ORDER, TYPE, LENGTH OF ENTRIES IN THE COMMON- ! 26: C CHECKS FOR VARIABLY DIMENSIONED ARRAYS. ! 27: C FORMS COMMONLIST ENTRY FOR BLOCK OFF SUBPGM AT LAT(PP) ! 28: C IF FOUND COMMON IN COM, COMPARES OLD DEFN TO NEW FOR ORDER, LEN, ! 29: C TYPE OF ENTRIES; FLAGS INCONSISTENCIES; NOTES IF COMMON IN ! 30: C TWO BLOCK DATA PGMS. COMMON IS AT DSA(K) ! 31: C ! 32: DATA R(1), R(4) /2*1/, R(2), R(3), R(5) /3*2/, ST /1H*/ ! 33: DATA ZERO(1) /0/ ! 34: C ! 35: C CHECK ISNT IN NODE AS PROCEDURE NAME ! 36: C ! 37: IF (FINDND(DSA(K+4),KK)) 20, 20, 10 ! 38: 10 CALL ERROR2(41H COMMON BLOCK HAS SAME NAME AS SUBPROGRAM, 41, ! 39: * DSA(K+4), 1, 1, 1) ! 40: C ! 41: C CHECK IF IN COM ALREADY ! 42: C ! 43: 20 KK = FINDCM(DSA(K+4)) ! 44: IF (KK) 30, 30, 60 ! 45: C ! 46: C CREATE NEW ENTRY ! 47: C ! 48: 30 IF (PCOM+SYMLEN+5.GT.LCOM) GO TO 260 ! 49: DO 40 I=1,SYMLEN ! 50: L = PCOM + I - 1 ! 51: LL = K + I + 3 ! 52: COM(L) = DSA(LL) ! 53: 40 CONTINUE ! 54: C ! 55: C MARK COMMON SET WHEN IT IS CREATED BY A BLOCK-DATA ! 56: C SUBPROGRAM WHICH SET IT ! 57: C ! 58: DO 50 I=1,4 ! 59: LL = L + I ! 60: COM(LL) = 0 ! 61: 50 CONTINUE ! 62: COM(LL+1) = PP ! 63: IF (IGATT1(NAME,8).EQ.11 .AND. IGATT1(K,2).EQ.1) COM(L+2) = 1 ! 64: KK = PCOM ! 65: PCOM = PCOM + SYMLEN + 5 ! 66: C ! 67: C GATHER INFO ABT LENGTH,TYPE,ORDER OF ELEMENTS ! 68: C ! 69: 60 L = 0 ! 70: S(1) = 0 ! 71: S(2) = 0 ! 72: S(3) = 0 ! 73: I = DSA(K+2) ! 74: 70 IF (I) 130, 130, 80 ! 75: C ! 76: C READING LIST OF ELEMENTS IN COMMON-CHECK TYPE,STRUCTURE ! 77: C ! 78: 80 K1 = IGATT1(DSA(I),1) ! 79: K2 = IGATT1(DSA(I),7) ! 80: K1 = MOD(K1,8) ! 81: IF (K1.EQ.5) K1 = 2 ! 82: C ! 83: C R(I) CONTAINS PROPER ORDER OF TYPE I IN DEFN OF COMMON ! 84: C ! 85: LL = R(K1+1) ! 86: IF (LL.LT.L) GO TO 120 ! 87: IF (K2) 90, 90, 100 ! 88: 90 S(LL) = S(LL) + 1 ! 89: GO TO 110 ! 90: 100 K2 = DSA(I) ! 91: K2 = DSA(K2+2) ! 92: S(LL) = S(LL) + DSA(K2) ! 93: 110 I = DSA(I+1) ! 94: L = LL ! 95: GO TO 70 ! 96: C ! 97: C ACCUMULATE COUNTS OF TYPES-NOTE TYPES OUT OF ORDER CAUSES ! 98: C TRUNCATION OF THE DEFINITION ! 99: C ! 100: 120 CALL ERROR2(41H ILLEGAL ORDERING OF DATA-TYPES IN COMMON, 41, ! 101: * COM(KK), 1, 1, 0) ! 102: CALL ERROR2(1H1, 0, ZERO(1), -1, 0, 1) ! 103: 130 S(3) = S(1) + S(2) ! 104: C ! 105: C HANG COMMONLIST ENTRY OFF PP NODE, IF NOT ALREADY THERE FROM SET ! 106: C ! 107: L = PP + SYMLEN + 2 ! 108: I = MATCH(LAT(L),2,-K) ! 109: IF (I.GT.0) GO TO 140 ! 110: I = MATCH(LAT(L),2,KK) ! 111: IF (I.LE.0) GO TO 150 ! 112: 140 LAT(I) = KK ! 113: GO TO 160 ! 114: C ! 115: C CREATE NEW ENTRY ! 116: C ! 117: 150 IF (PLAT+3.GT.LLAT) GO TO 280 ! 118: LAT(PLAT) = KK ! 119: LAT(PLAT+1) = 0 ! 120: LAT(PLAT+2) = LAT(L) ! 121: LAT(L) = PLAT ! 122: PLAT = PLAT + 3 ! 123: 160 I = KK + SYMLEN ! 124: IF (COM(I)) 170, 170, 190 ! 125: C ! 126: C NEW DEFN ! 127: C ! 128: 170 COM(I) = S(3) ! 129: COM(I+2) = S(1) ! 130: COM(I+3) = S(2) ! 131: 180 RETURN ! 132: C ! 133: C COMPARE LENGTHS OF EACH TYPE ! 134: C ! 135: 190 L = KK + SYMLEN + 2 ! 136: BLANK = .FALSE. ! 137: CALL S5UNPK(COM(KK), SS(1), 1) ! 138: IF (SS(1).EQ.ST) BLANK = .TRUE. ! 139: IBR = 0 ! 140: IF (COM(L+1).NE.S(2)) IBR = 1 ! 141: IF (COM(L).NE.S(1)) IBR = -1 ! 142: C BLANK COMMON DEFNS MATCH ! 143: IF (IBR.EQ.0 .AND. BLANK) GO TO 180 ! 144: C NAMED COMMON DEFNS MATCH ! 145: IF (IBR.EQ.0 .AND. .NOT.BLANK) GO TO 210 ! 146: C BLANK COMMON DONT MATCH ! 147: IF (IBR.NE.0 .AND. BLANK) GO TO 230 ! 148: C NAMED COMMONS DONT MATCH -- ERROR ! 149: 200 CALL ERROR2(25H INCOMPATIBLE COMMON DEFN, 25, COM(KK), 1, 1, ! 150: * 0) ! 151: K1 = KK + SYMLEN + 4 ! 152: K1 = COM(K1) ! 153: CALL ERROR2(3H IN, 3, LAT(K1), 1, 0, 0) ! 154: CALL ERROR2(4H AND, 4, LAT(PP), 1, 0, 1) ! 155: IF (BLANK) GO TO 180 ! 156: C ! 157: C CHECK DOUBLE SETTING OF BLOCK ! 158: C ! 159: 210 IF (IGATT1(K,2).NE.1 .OR. IGATT1(NAME,8).NE.11) GO TO 180 ! 160: IF (COM(L-1).NE.1) GO TO 220 ! 161: CALL ERROR2( ! 162: * 53H COMMON BLOCK INITIALIZED IN TWO BLOCK DATA SUBPGMS , 53, ! 163: * COM(KK), 1, 1, 1) ! 164: GO TO 180 ! 165: 220 COM(L-1) = 1 ! 166: GO TO 180 ! 167: C ! 168: C CHECK ARE LENGTHENING BLANK COMMON OFF THE END ! 169: C ! 170: 230 IF(IBR.EQ.(-1)) GOTO 250 ! 171: C ARE LENGTHENING OFF END ! 172: C KEEP LONGEST DEFN ! 173: IF (COM(L+1).GT.S(2)) GO TO 180 ! 174: 240 COM(L+1) = S(2) ! 175: LL = SYMLEN + KK ! 176: COM(LL) = S(3) ! 177: COM(LL+4) = PP ! 178: GO TO 180 ! 179: C SEE ARE REALLY LENGTHENING OFF END IF ! 180: C DEFNS DIFFER IN FIRST DATA TYPE AREAS ! 181: 250 IF (S(1).LT.COM(L) .AND. S(2).EQ.0) GO TO 180 ! 182: IF (.NOT.(S(1).GT.COM(L) .AND. COM(L+1).EQ.0)) GO TO 200 ! 183: COM(L) = S(1) ! 184: GO TO 240 ! 185: 260 CALL ERROR1(33H IN SETCOM, TABLE OVERFLOW OF COM, 33) ! 186: 270 SYSERR = .TRUE. ! 187: GO TO 180 ! 188: 280 CALL ERROR1(33H IN SETCOM, TABLE OVERFLOW OF LAT, 33) ! 189: GO TO 270 ! 190: END
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.