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