Return to SETEXT.f CVS log

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

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

1.1     ! root        1:       SUBROUTINE SETEXT
        !             2:       INTEGER Z, FINDND, PLAT, PNODE, PP, SS(3), SYMLEN
        !             3:       INTEGER BLANK
        !             4:       LOGICAL ERR, SYSERR, ABORT
        !             5:       COMMON /SCR1/ LINODE, INODE(500)
        !             6:       COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
        !             7:       COMMON /INTS/ Z(346)
        !             8:       COMMON /DETECT/ ERR, SYSERR, ABORT
        !             9:       COMMON /HEAD/ LNODE, PNODE, NODE(500)
        !            10:       COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
        !            11:       DATA BLANK /1H /
        !            12: C
        !            13: C     SUBROUTINE SETS UP DEFNS FOR BASIC EXTERNAL FCNS USED IN PASS 1
        !            14: C     FLUSH PAST INTRINSICS IN TABLE
        !            15: C
        !            16:       K = 1
        !            17:       DO 10 I=1,31
        !            18:         K = K + Z(K) + 2
        !            19:    10 CONTINUE
        !            20: C
        !            21: C     SEARCH EXTERNAL ENTRIES IN TABLE TO SEE WHICH HAVE BEEN USED
        !            22: C
        !            23:       DO 90 I=1,24
        !            24:         N = K + Z(K) + 1
        !            25:         L = Z(N)/1024
        !            26:         IF (L) 80, 80, 20
        !            27: C
        !            28: C     SEE IF THIS EXTERNAL FCN HAS BEEN USER DEFINED
        !            29: C
        !            30:    20   L = Z(K)
        !            31:         DO 30 J=1,SYMLEN
        !            32:           SS(J) = BLANK
        !            33:    30   CONTINUE
        !            34:         CALL S5PACK(Z(K+1), SS, L)
        !            35:         LL = FINDND(SS(1),J)
        !            36:         IF (LL.NE.0) GO TO 80
        !            37: C
        !            38: C     SETUP LATTICE ENTRY FOR THIS EXERNAL FCN
        !            39: C
        !            40:         IF (PNODE+1.GE.LNODE) GO TO 120
        !            41:         IF (PLAT+SYMLEN+8.GE.LLAT) GO TO 110
        !            42: C     SET LEVEL OF BASIC EXTERNAL FUNCTION TO -2
        !            43:         INODE(PNODE) = -2
        !            44:         NODE(PNODE) = PLAT
        !            45:         PNODE = PNODE + 1
        !            46:         DO 40 J=1,SYMLEN
        !            47:           L = PLAT + J - 1
        !            48:           LAT(L) = SS(J)
        !            49:    40   CONTINUE
        !            50:         PP = PLAT
        !            51:         PLAT = PLAT + SYMLEN
        !            52:         LAT(PLAT) = MOD(Z(N),512)/128
        !            53:         L = PLAT + 1
        !            54:         LL = PLAT + 5
        !            55:         DO 50 NN=L,LL
        !            56:           LAT(NN) = 0
        !            57:    50   CONTINUE
        !            58:         LAT(PLAT+6) = 6 + 8*MOD(Z(N),8)
        !            59:         NO = LAT(PLAT)
        !            60:         PLAT = PLAT + 7
        !            61: C
        !            62: C     FILL IN ARG ENTRIES
        !            63: C     NO CONTAINS NUMBER OF ARGS
        !            64: C
        !            65:         IF ((PLAT+4)*NO.GE.LLAT) GO TO 110
        !            66:         L = PP + SYMLEN + 1
        !            67:    60   LL = PLAT + 3
        !            68:         DO 70 NN=PLAT,LL
        !            69:           LAT(NN) = 0
        !            70:    70   CONTINUE
        !            71:         CALL SATT2(PLAT, 1, MOD(Z(N),64)/8)
        !            72:         CALL SATT2(PLAT, 4, 1)
        !            73:         CALL SATT2(PLAT, 8, 10)
        !            74:         LAT(L) = PLAT
        !            75:         LAT(PLAT+1) = 1
        !            76:         L = PLAT + 3
        !            77:         PLAT = PLAT + 4
        !            78:         IF (NO.EQ.1) GO TO 80
        !            79:         NO = NO - 1
        !            80:         GO TO 60
        !            81:    80   K = N + 1
        !            82:    90 CONTINUE
        !            83:   100 RETURN
        !            84:   110 CALL ERROR1(33H IN SETEXT, TABLE OVERFLOW OF LAT, 33)
        !            85:       GO TO 130
        !            86:   120 CALL ERROR1(34H IN SETEXT, TABLE OVERFLOW OF NODE, 34)
        !            87:   130 SYSERR = .TRUE.
        !            88:       GO TO 100
        !            89:       END

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