Return to DATA.f CVS log

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

researchv10 Norman

      SUBROUTINE DATA
      LOGICAL ERR, SYSERR, ABORT, REPL, ARDECL, SIGN, TOKPNO, ERROR
      INTEGER DECNT, DATCNT, STMT, PSTMT, GETTOK, STACK, S(10), DSA,
     *    PDSA
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /CEXPRS/ LSTACK, STACK(620)
      DATA IS /1H*/
C
C     ROUTINE PROCESSES A DATA STMT
C
   10 DECNT = 0
   20 IF (ARDECL(K2,KK)) GO TO 30
      IF (.NOT.ERR) GO TO 30
      CALL ERROR1(19H ILLEGAL DECLARATOR, 19)
      IF(.NOT.SYSERR)  GOTO 260
   30 IF (SYSERR) RETURN
C
C     SET DECLARATOR USAGE AS VARIABLE;  CHECK ITS NOT IN BLANK COMMON
C     CANNOT BE INLABELLED COMMON IF THIS STMT NOT IN BLOCK DATA PGM
C     FOUND A DECLARATOR ADD IT TO LIST OF ALL DECLS SO CAN CHECK
C     TYPE OF ITS CORRESPONDING DATA-ITEM;  ADD IN COUNT SO CAN
C     CHECK NUMBER OF DECLS VS. NUMBER OF DATA-ITEMS
C     KEEP TYPE INFO ON STACK; DECNT IS LENGTH OF STACK
C
      I = IGATT1(KK,8)
      IF (I.EQ.0) CALL SATT1(KK, 8, 10)
      I = IGATT1(KK,2)
      NN = IGATT1(NAME,8)
      IF (I) 60, 60, 40
C
C     IF VARIABLE IN COMMON, CHECK TO SEE IF CAN LEGALLY APPEAR
C     IN DATA STMT
C
   40 I = DSA(KK+2)
      I = DSA(I+1)
      CALL S5UNPK(DSA(I+4), S(1), 6)
      IF (S(1).EQ.IS) GO TO 50
C
C     FOUND NO "*" SO ARE IN LABELLED COMMON
C
      IF (NN.EQ.11) GO TO 70
      CALL ERROR1(
     *    55H ILLEGAL TO INITIALIZE VARIABLE IN LABELLED COMMON HERE,
     *    55)
      GO TO 260
C
C     FOUND BLANK COMMON
C
   50 CALL ERROR1(48H ILLEGAL TO INITIALIZE VARIABLES IN BLANK COMMON,
     *    48)
      GO TO 260
   60 IF (NN.NE.11) GO TO 70
      CALL ERROR1(33H DATA-ITEM NOT IN LABELLED COMMON, 33)
      GO TO 260
   70 I = IGATT1(KK,1)
      CALL SATT1(KK, 5, 1)
      NN = 1
      IF (IGATT1(KK,7).EQ.0) GO TO 75
      IF (STMT(K2-1).EQ.62) GO TO 75
      N = DSA(KK+2)
      NN = DSA(N)
   75 CONTINUE
      IF (DECNT+3.LE.LSTACK) GO TO 76
      CALL ERROR1(33H IN DATA, TABLE OVERFLOW OF STACK , 33 )
      GO TO 260
   76 CONTINUE
      STACK(DECNT+1) = MOD(I,8)
      STACK(DECNT+2) = KK
      STACK(DECNT+3) = NN
      DECNT = DECNT + 3
      IF (STMT(K2).EQ.67) GO TO 100
      IF (STMT(K2).NE.68) GO TO 90
      PSTMT = K2 + 1
      IF (PSTMT.LT.NSTMT) GO TO 20
   80 CALL ERROR1(15H ILLEGAL SYNTAX, 15)
      RETURN
   90 CALL ERROR1(33H ILLEGAL PUNCTUATION IN DATA STMT, 33)
      GO TO 260
C
C     FIND DATA-ITEMS; CHECK ITS TYPE VS. CORRESPONDING DECLARATOR
C     SIGN .TRUE. IF DATA-ITEM PRECEEDED BY A SIGN
C     REPL .TRUE. IF A REPLICATION FACTOR HAS ALREADY BEEN FOUND
C
  100 DATCNT = 0
      ERROR = .FALSE.
      PSTMT = K2 + 1
  110 IF (PSTMT.EQ.NSTMT) GO TO 80
      SIGN = .FALSE.
      REPL = .FALSE.
      NN = 1
  120 IF (STMT(PSTMT).NE.60 .AND. STMT(PSTMT).NE.61) GO TO 130
      PSTMT = PSTMT + 1
      SIGN = .TRUE.
  130 IF (PSTMT.EQ.NSTMT) GO TO 80
      KK = GETTOK(PSTMT,K2)
      IF (ERR) GO TO 80
      IF (KK.LT.6) GO TO 150
  140 CALL ERROR1(18H ILLEGAL DATA-ITEM, 18)
      GO TO 260
  150 KK = KK + 1
      GO TO (200, 200, 160, 190, 190, 180), KK
C
C     MUST MAKE SURE THAN AN INTEGER DATA-ITEM ISN'T A REPLICATION FACTO
C
  160 IF (REPL) GO TO 200
      IF(SIGN .OR. STMT(K2).NE.66) GOTO 200
      IF(TOKPNO(PSTMT,K2,NN)) GOTO 170
      CALL ERROR1(27H ILLEGAL REPLICATION FACTOR ,27)
      NN = 1
  170 REPL = .TRUE.
      PSTMT = K2 + 1
      GO TO 120
C
C     CHECK LENGTH OF HOLLERITH DATA-ITEM; MUST FIT INTO INTEGER WORD
C
  180 IF (STMT(PSTMT)+2048.EQ.1 .OR. ERROR) GO TO 190
      CALL ERROR1(
     *    53H WARNING - NH WITH N.GT.1 IS NOT A PORTABLE CONSTRUCT, 53)
      ERROR = .TRUE.
C
C     CHECK COMPLEX, HOLLERITH, AND LOGICAL DATA-ITEMS ARE UNSIGNED
C
  190 IF (SIGN) GO TO 140
C
C     CHECK COMPATIBLITY OF DATA-ITEMS WITH DECLARATORS
C     NN IS REPLICATION FACTOR;
C
200   IBR=0
      DO 220 I = 1,NN
        IF (STACK(DATCNT+3).EQ.0) DATCNT = DATCNT + 3
        IF (DATCNT .GE. DECNT) GO TO 240
        STACK(DATCNT+3) = STACK(DATCNT+3) - 1
        IF (STACK(DATCNT+1).EQ.KK-1) GO TO 220
        IF ((STACK(DATCNT+1).NE.2 .OR. KK.NE.6) .AND.
     *      (STACK(DATCNT+1).NE.5 .OR. KK.NE.3)) GO TO 210
        CALL SATT1(STACK(DATCNT+2), 1, 5)
        GO TO 220
 210  IBR = 1
  220 CONTINUE
      IF(IBR .EQ. 1) CALL ERROR1(52
     1H WARNING - DATA-ITEM IS INCOMPATIBLE WITH DECLARATOR ,52)
C
C     CHECK FOR "," BETWEEN DATA-ITEMS
C
      IF (STMT(K2).NE.68) GO TO 230
      PSTMT = K2 + 1
      GO TO 110
C
C     CHECK FOR ANOTHER SET OF DECLARATORS/DATA-ITEMS
C
  230 IF (STMT(K2).NE.67) GO TO 90
      IF (STACK(DATCNT+3).EQ.0) DATCNT = DATCNT + 3
      IF (DATCNT.EQ.DECNT) GO TO 250
  240 CALL ERROR1(34H MISSING DECLARATORS OR DATA-ITEMS, 34)
      IF (DATCNT.GE.DECNT) GO TO 260
  250 PSTMT = K2 + 1
      IF (PSTMT.EQ.NSTMT) RETURN
      IF (STMT(PSTMT).NE.68) GO TO 90
      PSTMT = PSTMT + 1
      IF (PSTMT.NE.NSTMT) GO TO 10
      GO TO 80
C
C     FLUSH TO "/," CONSTRUCT OR END OF STATEMEMT
C
  260 IF (PSTMT+1.GE.NSTMT) RETURN
      IF (STMT(PSTMT).EQ.67 .AND. STMT(PSTMT+1).EQ.68) GO TO 270
      PSTMT = PSTMT + 1
      GO TO 260
  270 PSTMT = PSTMT + 2
      IF (PSTMT.GE.NSTMT) RETURN
      GO TO 10
      END

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