Return to DOSPEC.f CVS log

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

researchv10 Norman

      SUBROUTINE DOSPEC(KK, K2, LOG)
      INTEGER STMT, PSTMT, DOPT, DOLIST, LOOKUP
      LOGICAL SYSERR, ABORT, DOVAR, ERR, TOKPNO, LOG
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      COMMON /LISTDO/ LPT, LEN, LS(64)
      COMMON /DOS/ DOPT, LDO, DOLIST(192)
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      COMMON /DETECT/ ERR, SYSERR, ABORT
C
C     ROUTINE RECOGNIZES DO-SPECIFICATION CONSTRUCT
C     DOLIST ARRAY IS DO STACK USED TO CHECK NESTING; 6 WORD ENTRY
C     WORD 1-CURRENT STMT NO
C     WORD 2-INDEX OF LABEL IN DSA
C     WORD 3-INDEX OF DO CONTROL VARIABLE IN DSA
C     WORD 4-6,-INDICES OF LIMITS IN DSA OR 0 FOR CONSTANT LIMITS
C     LS ARRAY IS IMPLICIT  DO STACK- IN EACH ENTRY IS SAME DATA
C     AS WORDS 3-6 OF DOLIST ENTRIES.
C
      IF (.NOT.LOG) GO TO 10
      IF (LPT.LE.1) GO TO 20
      LPT = LPT - 4
      LS(LPT) = 0
      LS(LPT+1) = 0
      LS(LPT+2) = 0
      LS(LPT+3) = 0
      GO TO 40
   10 IF (DOPT.LE.LDO-11) GO TO 30
   20 CALL ERROR1(20H DO NESTING TOO DEEP, 20)
      GO TO 190
   30 DOPT = DOPT + 6
      DOLIST(DOPT) = NOST
      DOLIST(DOPT+1) = KK
      DOLIST(DOPT+2) = 0
      DOLIST(DOPT+3) = 0
      DOLIST(DOPT+4) = 0
      DOLIST(DOPT+5) = 0
C
C     DO CONTROL VARIABLE MUST BE INTEGER, SCALAR VARIABLE
C
   40 IF (PSTMT.LT.NSTMT) GO TO 60
   50 CALL ERROR1(35H ILLEGAL SYNTAX IN DO SPECIFICATION, 35)
      GO TO 190
   60 CALL NEXTOK(PSTMT, K2, K)
      IF (K.NE.0) GO TO 50
      K = LOOKUP(K2,.FALSE.)
      IF (SYSERR) GO TO 180
      I1 = IGATT1(K,1)
      IF (I1.GT.0) GO TO 70
      I1 = 1
      IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2
      CALL SATT1(K, 1, I1)
   70 I2 = IGATT1(K,7)
      I3 = IGATT1(K,8)
      IF (MOD(I1,8).NE.2 .OR. I2.NE.0) GO TO 220
      IF (I3.NE.0) GO TO 80
      I3 = 10
      CALL SATT1(K, 8, 10)
   80 IF (I3.NE.10) GO TO 220
      CALL SATT1(K, 5, 1)
      IF (DOVAR(K)) CALL ERROR1(
     *    57H ILLEGAL TO CHANGE VALUE OF CONTROL VARIABLE OR DO LIMITS,
     *    57)
      I3 = IGATT1(K,2)
      IF (I3.EQ.1) CALL ERROR1(37H WARNING - CONTROL VARIABLE IN COMMON,
     *    37)
      IF (K.EQ.NAME) CALL ERROR1(
     *    49H WARNING - FUNCTION NAME USED AS CONTROL VARIABLE, 49)
      IF (.NOT.LOG) GO TO 90
      LS(LPT) = K
      GO TO 100
   90 DOLIST(DOPT+2) = K
C
C     FIND AN =
C
  100 IF (STMT(K2).NE.63) GO TO 50
C
C     DO-LIMITS  LIMS COUNTS NUMBER OF  LIMITS; THESE MUST BE INTEGER
C     SCALAR VARIABLES OR POSITIVE INTEGER CONSTANTS
C
      LIMS = 0
  110 PSTMT = K2 + 1
      IF (PSTMT.GE.NSTMT) GO TO 50
      IF (.NOT.TOKPNO(PSTMT,K2,K)) GO TO 120
      LIMS = LIMS + 1
      GO TO 170
  120 CALL NEXTOK(PSTMT, K2, K)
      IF (K.NE.0) GO TO 210
      K = LOOKUP(K2,.FALSE.)
      IF (SYSERR) GO TO 180
      LIMS = LIMS + 1
      IF (.NOT.LOG) GO TO 130
      IF (LS(LPT).EQ.K) CALL ERROR1(17H ILLEGAL DO LIMIT, 17)
      I1 = LPT + LIMS
      LS(I1) = K
      GO TO 140
  130 IF (DOLIST(DOPT+2).EQ.K) CALL ERROR1(17H ILLEGAL DO LIMIT, 17)
      I1 = DOPT + 2 + LIMS
      DOLIST(I1) = K
  140 I1 = IGATT1(K,1)
      I2 = IGATT1(K,7)
      I3 = IGATT1(K,8)
      IF (I3.NE.0) GO TO 150
      CALL SATT1(K, 8, 10)
      I3 = 10
  150 IF (I3.NE.10) GO TO 50
      IF (I1.GT.0) GO TO 160
      I1 = 1
      IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2
      CALL SATT1(K, 1, I1)
  160 IF (MOD(I1,8).NE.2 .OR. I2.NE.0) GO TO 210
C
C     CHECK FOR END OF STMT
C
  170 IF (K2.LT.NSTMT .AND. STMT(K2).NE.62) GO TO 200
C
C     IF THERE ARE NO MORE CHARS, WE ARE DONE WITH THIS STMT;
C     THERE MUST BE AT LEAST 2 AND NO MORE THAN 3 LIMITS IN DO
C
      IF (LIMS.LE.1) GO TO 230
  180 RETURN
  190 ERR = .TRUE.
      GO TO 180
C
C     CHECK FOR A "," MUST FIND HERE
C
  200 IF (STMT(K2).NE.68) GO TO 50
      IF (LIMS.GE.3) GO TO 230
      GO TO 110
  210 CALL ERROR1(47H DO LIMIT NOT INTEGER SCALAR VAR OR POS INTEGER,
     *    47)
      GO TO 190
  220 CALL ERROR1(36H CONTROL VARIABLE NOT INTEGER SCALAR, 36)
      GO TO 190
  230 CALL ERROR1(18H ILLEGAL DO LIMITS, 18)
      GO TO 190
      END

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