![[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.