Return to ASLEV.f CVS log

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

Annotation of researchv10no/cmd/pfort/ASLEV.f, revision 1.1

1.1     ! root        1:       SUBROUTINE ASLEV(IPT)
        !             2: C
        !             3: C      ASLEV TAKES A SUBLATTICE WITH ITS ROOT AT NODE(IABS(IPT)))
        !             4: C      AND READJUSTS THE LEVELS IN THE SUBLATTICE
        !             5: C      IN ACCORDANCE WITH NEW LEVEL AT ROOT
        !             6: C     NOTE, IPT LT 0 FROM CALL IN SETREF  (EXT) AND FROM ACTUALS
        !             7: C     PASSED DOWN IN PROC
        !             8: C
        !             9:       INTEGER PNODE, STACK, PLAT, FIND, SYMLEN
        !            10:       INTEGER ZERO(1)
        !            11:       LOGICAL SYSERR, ERR, ABORT, GR
        !            12:       COMMON /DETECT/ ERR, SYSERR, ABORT
        !            13:       COMMON /HEAD/ LNODE, PNODE, NODE(500)
        !            14:       COMMON /SCR1/ LINODE, INODE(500)
        !            15:       COMMON /SCR2/ LSTACK, STACK(500)
        !            16:       COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
        !            17:       COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
        !            18:       DATA ZERO(1) /0/
        !            19: C
        !            20: C     STACK (IS) IS SIGNED NODE INDEX OF SUBPGM
        !            21: C     IF GT 0, NODE IS ALONG A RED LINK TO PARENT
        !            22: C     IF LT 0, NODE IS ALONG  A GREEN LINK TO PARENT
        !            23: C
        !            24: C     STACK(IS+1) IS PTR TO TWO WORD DESC ENTRY FOR THIS
        !            25: C     SUBPGM, OR 0 FOR END OF DESC LIST
        !            26: C
        !            27:       K = IABS (IPT )
        !            28:       K = SYMLEN + NODE(K) + 4
        !            29:       STACK(2) = IPT
        !            30:       STACK (1) = IABS ( LAT(K) )
        !            31:       IS = 2
        !            32: C      DOES TOP OF STACK ENTRY HAVE UNVISITED DESC
        !            33:    10 IF (STACK(IS-1).NE.0) GO TO 20
        !            34: C      TEST IF ARE DONE WITH SUBLATTICE
        !            35:       IF (IS.EQ.2) RETURN
        !            36: C      POP UP A LEVEL IN PATH
        !            37:       IS = IS - 2
        !            38:       GO TO 10
        !            39: C      UPDATE ENTRY OF NEXT DESCENDENT TO BE CHECKED ON STACK
        !            40:    20 K = STACK(IS-1)
        !            41:       STACK(IS-1) = IABS (LAT(K+1))
        !            42: C     LAT(K) CONTAINS SIGNED INDEX OF DESC BEING PROCESSED
        !            43: C     SIGN INDICATES COLOR OF LINK TO PARENT, (I.E.
        !            44: C     NODE AT TOP OF STACK)
        !            45: C     LT 0 IS GREEN LINK, GT 0 IS RED LINK
        !            46: C     L IS INDEX IN NODE(*) OF DESC BEING PROCESSED
        !            47: C     KK IS INDEX IN LAT(*) OF DESC BEING PROCESSED
        !            48:       LL = 1
        !            49:       IF( LAT(K) .LT. 0) LL = -1
        !            50:       KK = IABS(LAT(K))
        !            51:       L = FIND(KK)
        !            52: C     SKIP ALL DESC WITH NEGATIVE LEVELS
        !            53:       IF (INODE(L).LT.0) GO TO 10
        !            54: C     SEE IF STACK TOO SHORT FOR LOOPS
        !            55:       IF( IS.LE.2) GOTO 40
        !            56: C     CHECK FOR LOOPS IN PATH STACK DESC
        !            57:       LOOP = 0
        !            58:       GR = .FALSE.
        !            59:       IF(LL.EQ.(-1)) GR = .TRUE.
        !            60:       DO 60 I = 2,IS,2
        !            61:       IF(LOOP) 70,70,90
        !            62:    90 IF(STACK(I).LT.0) GR = .TRUE.
        !            63:       GOTO 60
        !            64:  70   IF(L.EQ.IABS(STACK(I))) LOOP = I
        !            65:  60   CONTINUE
        !            66: C      NO LOOPS
        !            67:       IF(LOOP.EQ.0) GOTO 40
        !            68: C     LOOP OF MIXED COLORED LINKS
        !            69: C     DO NOT STACK DESC
        !            70:       IF(GR) GOTO 10
        !            71: C     RECURSION
        !            72:       ABORT = .TRUE.
        !            73:       CALL ERROR2(19H RECURSIVE CALL OF ,19,LAT(KK), 1, 1, 0)
        !            74:       DO 80 K=LOOP,IS,2
        !            75:       KK = IABS(STACK(K))
        !            76:       KK = NODE(KK)
        !            77:  80   CALL ERROR2(11H INVOLVING ,11,LAT(KK),1, 0, 0)
        !            78:       CALL ERROR2(1H1, 0, ZERO, -3, 0, 1)
        !            79:    30 RETURN
        !            80: C      TEST IF DESC LEVEL IS ALREADY GT LEVEL OF PAR
        !            81: C      THEN NEEDNT CHECK PART OF SUBLATTICE UNDER THIS DESC
        !            82:    40 K = IABS (STACK(IS))
        !            83:       IF (INODE(L).GT.INODE(K)) GO TO 10
        !            84: C      PUSH DESC ONTO STACK AFTER FIXING HIS LEVEL
        !            85:       INODE(L) = INODE(K) + 1
        !            86: C      TEST AGAINST LNODE BECAUSE  SCRATCH ARRAY
        !            87: C      IS AS LONG AS NODE ARRAY
        !            88:       IF (IS+2.GT.LNODE) GO TO 50
        !            89:       STACK(IS+2) = LL * L
        !            90:       K = NODE(L) + SYMLEN + 4
        !            91:       STACK(IS+1) = IABS( LAT(K))
        !            92:       IS = IS + 2
        !            93:       GO TO 10
        !            94:    50 SYSERR = .TRUE.
        !            95:       CALL ERROR1(43H IN ASLEV, PATH LONGER THAN NUMBER OF NODES, 43)
        !            96:       GO TO 30
        !            97:       END

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