Return to OUT2.f CVS log

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

researchv10 Norman

      SUBROUTINE OUT2(ISR)
      INTEGER SYMLEN, PNODE, BL, PLAT, STACK, Q(3), C(12),
     *    OUTLAT, OUTCOM, OUTUT
      LOGICAL ERR, SYSERR, ABORT
      EXTERNAL EXCH
      COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, I1, I2, II1
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
      COMMON /CEXPRS/ LSTACK, STACK(620)
      COMMON /HEAD/ LNODE, PNODE, NODE(500)
      COMMON /SCR1/ LINODE, INODE(500)
      DATA C(1) /1HE/, C(2) /1HD/, C(3) /1HR/, C(4) /1HI/, C(5) /1HC/,
     *    C(6) /1HL/, C(7) /1HS/, C(8) /1HA/, C(9) /1HF/, IP /1HP/, IBL
     *    /1H-/, C(12) /1HU/, C(10) /1HB/, C(11) /1HN/
      DATA BL /1H /
C
C     ROUTINE PRINTS CALLING GRAPH
C
      IF (PNODE.LE.2) GO TO 110
C
C     GRAPH
C
      I3 = PNODE - 1
      IF (ISR.NE.0) I3 = I3 - 1
C
C     SORT LATTICE
C
      DO 10 I=1,I3
        INODE(I) = IABS(NODE(I))
   10 CONTINUE
      CALL SSORT(EXCH, LAT, LLAT, INODE, I3, 0)
      DO 100 IA=1,I3
        I = INODE(IA)
        L = I + SYMLEN + 6
        IF (MOD(LAT(L),8).EQ.4) GO TO 100
        CALL S5UNPK(LAT(I), STACK(1), 6)
        WRITE (OUTUT,99999) (STACK(L),L=1,6)
99999   FORMAT (///1X, 6A1//)
C
C     GET ARGS IF ANY
C
        IS = 1
        K = SYMLEN + I
        L = LAT(K)
        IF (L) 70, 70, 20
   20   K = K + 1
        K = LAT(K)
        IF (L*8.GT.LSTACK) GO TO 120
        DO 60 LL=1,L
          Q(1) = IGATT2(K,8)
          IF (Q(1).EQ.5 .OR. Q(1).EQ.6 .OR. Q(1).EQ.13) GO TO 30
          Q(1) = IGATT2(K,1)
          Q(2) = IGATT2(K,5)
          Q(3) = IGATT2(K,7)
          STACK(IS) = IBL
          STACK(IS+2) = IBL
          IF (Q(1).GE.8) STACK(IS) = C(1)
          L1 = MOD(Q(1),8) + 2
          STACK(IS+1) = C(L1)
          IF (Q(2).EQ.1) STACK(IS+2) = C(7)
          STACK(IS+3) = C(7)
          IF (Q(3).NE.0) STACK(IS+3) = C(8)
          GO TO 40
   30     STACK(IS) = IP
          STACK(IS+1) = IBL
          STACK(IS+2) = IBL
          STACK(IS+3) = IBL
   40     DO 50 LK=4,7
            L1 = LK + IS
            STACK(L1) = BL
   50     CONTINUE
          IS = IS + 8
          K = LAT(K+3)
   60   CONTINUE
      IS = IS - 1
C     PRINT ARGUMENTS
      K = 48
      IF (K.GT.IS) K = IS
      WRITE(OUTUT,99998)(STACK(LK), LK=1,K)
99998 FORMAT(20H ARGUMENT ATTRIBUTES ,5X,6(8A1,1X))
      IF( K.EQ.IS ) GOTO 70
 65   LK = K + 1
      K = LK + 47
      IF(K.GT.IS) K = IS
      WRITE(OUTUT,99997) (STACK(L1),L1=LK,K)
99997 FORMAT(25X,6(8A1,1X))
      IF(K.LT.IS) GOTO 65
C
C     GET COMMON NAMES
C
   70   K = I + SYMLEN + 2
        K = OUTCOM(LAT(K),IS)
        IF (SYSERR) GO TO 110
        IF (K.EQ.0) GO TO 80
      CALL OUT2A(14H COMMON BLOCKS, 14, IS, 2)
C
C     FIND PARENTS
C
   80   K = I + SYMLEN + 3
        K = OUTLAT(LAT(K),IS,ISR)
        IF (SYSERR) GO TO 110
        IF (K.EQ.0) GO TO 90
      CALL OUT2A(22H CALLED BY SUBPROGRAMS, 22, IS, 1)
C
C     FIND DESCENDENTS
C
   90   K = I + SYMLEN + 4
        K = OUTLAT(LAT(K),IS,ISR)
        IF (SYSERR) GO TO 110
        IF (K.EQ.0) GO TO 100
      CALL OUT2A(18H CALLS SUBPROGRAMS, 18, IS, 1)
  100 CONTINUE
  110 RETURN
  120 SYSERR = .TRUE.
      CALL ERROR1(33H IN OUT2, TABLE OVERFLOW OF STACK, 33)
      GO TO 110
      END

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