V10/cmd/pfort/SUBFCN.f

      SUBROUTINE SUBFCN(TYPE)
C
C     TYPE IS EXPLICIT TYPE OF FUNCTION, ELSE IS -1
C     ALL FCNS GIVEN EXPLICIT TYPE SINCE FCN NAME CANNOT APPEAR IN
C     NONEXECUTABLE STMT WITHIN FCN SUBPRGM EXCEPT HEAD STMT
C     ROUTINES DEFINES SUBROUTINE AND FUNCTION NAMES AND CREATES
C     LINKED LISTS OF POINTERS TO THEIR ARGUMENTS IN DSA.
C     SETS NAME TO POINT TO CURRENT FUNCN OR SUBRTNE.  IN CASE
C     OF BAD SYNTAX IN NAME CONSTRUCT OR FCN WITHOUT PARAMS.,
C     PROGRAM UNIT BECOMES MAIN PGM BY DEFAULT
C
      INTEGER STMT, PSTMT, DSA, SYMHD, TYPE, BNEXT, S(5), PDSA
      LOGICAL ERR, SYSERR, ABORT
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /DETECT/ ERR, SYSERR, ABORT
      DATA S(1) /66/, S(2) /42/, S(3) /30/, S(4) /38/, S(5) /43/
      KCELL = 0
      CALL NEXTOK(PSTMT, K2, I1)
      IF (I1.NE.0) GO TO 120
C
C     SET FCN OR SUBR USE IN SYMBOL TABLE. TYPE FCN AND RECORD EXPLICIT
C     OR IMPLICIT TYPE
C
      K = LOOKUP(K2,.FALSE.)
      IF (SYSERR) GO TO 90
      NAME = K
      L = ITYP - 8
      GO TO (10, 20), L
   10 CALL SATT1(K, 8, 3)
      GO TO 40
   20 CALL SATT1(K, 8, 4)
      IF (TYPE.LT.0) GO TO 30
      CALL SATT1(K, 1, TYPE+8)
      GO TO 40
   30 L = 1
      IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) L = 2
      CALL SATT1(K, 1, L)
   40 IF (STMT(K2).NE.65) GO TO 140
   50 PSTMT = K2 + 1
      IF (PSTMT.GE.NSTMT) GO TO 120
      CALL NEXTOK(PSTMT, K2, L)
      IF (L.NE.0) GO TO 80
C
C     ENTER PARAMETER IN SYMBOL TABLE; TYPE IMPLICITLY; ADD ONTO PARAM
C     LIST HANGING OFF SUBR/FCN NAME; SET DUMMYARG BIT ON; DO NOT SET
C     USAGE
C
      N = LOOKUP(K2,.FALSE.)
      IF (SYSERR) GO TO 90
      I2 = IGATT1(N,4)
      I1 = IGATT1(N,8)
      IF (I1.NE.0 .OR. I2.NE.0) GO TO 80
      L = 1
      IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) L = 2
      CALL SATT1(N, 1, L)
      L = IGATT1(N,4)
      IF (L.EQ.1) GO TO 80
      CALL SATT1(N, 4, 1)
      IF (NEXT+2.GE.BNEXT) GO TO 150
      IF (KCELL.EQ.0) GO TO 60
      DSA(KCELL+1) = NEXT
      GO TO 70
C
C     START PARAM LIST
C
   60 DSA(K+2) = NEXT
   70 KCELL = NEXT
      DSA(NEXT) = N
      DSA(NEXT+1) = 0
      NEXT = NEXT + 2
C
C     SEARCH FOR  ")" OR ","
C
      IF (STMT(K2).EQ.62) GO TO 100
      IF (STMT(K2).EQ.68) GO TO 50
   80 CALL ERROR1(33H ILLEGAL SYNTAX IN PARAMETER LIST, 33)
   90 RETURN
  100 K2 = K2 + 1
  110 IF (K2.EQ.NSTMT) GO TO 90
      CALL ERROR1(39H ILLEGAL CHARACTERS AFTER SUBR/FCN HEAD, 39)
      GO TO 90
  120 CALL ERROR1(15H ILLEGAL SYNTAX, 15)
      PSTMT = 6
      DO 130 I1=1,5
        STMT(I1+5) = S(I1)
  130 CONTINUE
      NAME = LOOKUP(11,.FALSE.)
      IF (SYSERR) GO TO 90
      CALL SATT1(NAME, 8, 11)
      GO TO 90
  140 IF (ITYP.EQ.9) GO TO 110
      CALL ERROR1(20H NO PARAMS SPECIFIED, 20)
      GO TO 120
  150 SYSERR = .TRUE.
      CALL ERROR1(33H IN SUBFCN, TABLE OVERFLOW OF DSA,33)
      GO TO 90
      END