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

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.