![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to OUT2.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 OUT2.f CVS log | Up to [Research Unix] / researchv10no / cmd / pfort |
1.1 root 1: SUBROUTINE OUT2(ISR)
2: INTEGER SYMLEN, PNODE, BL, PLAT, STACK, Q(3), C(12),
3: * OUTLAT, OUTCOM, OUTUT
4: LOGICAL ERR, SYSERR, ABORT
5: EXTERNAL EXCH
6: COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, I1, I2, II1
7: COMMON /DETECT/ ERR, SYSERR, ABORT
8: COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
9: COMMON /CEXPRS/ LSTACK, STACK(620)
10: COMMON /HEAD/ LNODE, PNODE, NODE(500)
11: COMMON /SCR1/ LINODE, INODE(500)
12: DATA C(1) /1HE/, C(2) /1HD/, C(3) /1HR/, C(4) /1HI/, C(5) /1HC/,
13: * C(6) /1HL/, C(7) /1HS/, C(8) /1HA/, C(9) /1HF/, IP /1HP/, IBL
14: * /1H-/, C(12) /1HU/, C(10) /1HB/, C(11) /1HN/
15: DATA BL /1H /
16: C
17: C ROUTINE PRINTS CALLING GRAPH
18: C
19: IF (PNODE.LE.2) GO TO 110
20: C
21: C GRAPH
22: C
23: I3 = PNODE - 1
24: IF (ISR.NE.0) I3 = I3 - 1
25: C
26: C SORT LATTICE
27: C
28: DO 10 I=1,I3
29: INODE(I) = IABS(NODE(I))
30: 10 CONTINUE
31: CALL SSORT(EXCH, LAT, LLAT, INODE, I3, 0)
32: DO 100 IA=1,I3
33: I = INODE(IA)
34: L = I + SYMLEN + 6
35: IF (MOD(LAT(L),8).EQ.4) GO TO 100
36: CALL S5UNPK(LAT(I), STACK(1), 6)
37: WRITE (OUTUT,99999) (STACK(L),L=1,6)
38: 99999 FORMAT (///1X, 6A1//)
39: C
40: C GET ARGS IF ANY
41: C
42: IS = 1
43: K = SYMLEN + I
44: L = LAT(K)
45: IF (L) 70, 70, 20
46: 20 K = K + 1
47: K = LAT(K)
48: IF (L*8.GT.LSTACK) GO TO 120
49: DO 60 LL=1,L
50: Q(1) = IGATT2(K,8)
51: IF (Q(1).EQ.5 .OR. Q(1).EQ.6 .OR. Q(1).EQ.13) GO TO 30
52: Q(1) = IGATT2(K,1)
53: Q(2) = IGATT2(K,5)
54: Q(3) = IGATT2(K,7)
55: STACK(IS) = IBL
56: STACK(IS+2) = IBL
57: IF (Q(1).GE.8) STACK(IS) = C(1)
58: L1 = MOD(Q(1),8) + 2
59: STACK(IS+1) = C(L1)
60: IF (Q(2).EQ.1) STACK(IS+2) = C(7)
61: STACK(IS+3) = C(7)
62: IF (Q(3).NE.0) STACK(IS+3) = C(8)
63: GO TO 40
64: 30 STACK(IS) = IP
65: STACK(IS+1) = IBL
66: STACK(IS+2) = IBL
67: STACK(IS+3) = IBL
68: 40 DO 50 LK=4,7
69: L1 = LK + IS
70: STACK(L1) = BL
71: 50 CONTINUE
72: IS = IS + 8
73: K = LAT(K+3)
74: 60 CONTINUE
75: IS = IS - 1
76: C PRINT ARGUMENTS
77: K = 48
78: IF (K.GT.IS) K = IS
79: WRITE(OUTUT,99998)(STACK(LK), LK=1,K)
80: 99998 FORMAT(20H ARGUMENT ATTRIBUTES ,5X,6(8A1,1X))
81: IF( K.EQ.IS ) GOTO 70
82: 65 LK = K + 1
83: K = LK + 47
84: IF(K.GT.IS) K = IS
85: WRITE(OUTUT,99997) (STACK(L1),L1=LK,K)
86: 99997 FORMAT(25X,6(8A1,1X))
87: IF(K.LT.IS) GOTO 65
88: C
89: C GET COMMON NAMES
90: C
91: 70 K = I + SYMLEN + 2
92: K = OUTCOM(LAT(K),IS)
93: IF (SYSERR) GO TO 110
94: IF (K.EQ.0) GO TO 80
95: CALL OUT2A(14H COMMON BLOCKS, 14, IS, 2)
96: C
97: C FIND PARENTS
98: C
99: 80 K = I + SYMLEN + 3
100: K = OUTLAT(LAT(K),IS,ISR)
101: IF (SYSERR) GO TO 110
102: IF (K.EQ.0) GO TO 90
103: CALL OUT2A(22H CALLED BY SUBPROGRAMS, 22, IS, 1)
104: C
105: C FIND DESCENDENTS
106: C
107: 90 K = I + SYMLEN + 4
108: K = OUTLAT(LAT(K),IS,ISR)
109: IF (SYSERR) GO TO 110
110: IF (K.EQ.0) GO TO 100
111: CALL OUT2A(18H CALLS SUBPROGRAMS, 18, IS, 1)
112: 100 CONTINUE
113: 110 RETURN
114: 120 SYSERR = .TRUE.
115: CALL ERROR1(33H IN OUT2, TABLE OVERFLOW OF STACK, 33)
116: GO TO 110
117: END
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.