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

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.