![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to DATA.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / pfort|
Return to DATA.f CVS log | Up to [Research Unix] / researchv10no / cmd / pfort |
1.1 ! root 1: SUBROUTINE DATA ! 2: LOGICAL ERR, SYSERR, ABORT, REPL, ARDECL, SIGN, TOKPNO, ERROR ! 3: INTEGER DECNT, DATCNT, STMT, PSTMT, GETTOK, STACK, S(10), DSA, ! 4: * PDSA ! 5: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 6: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 7: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 8: COMMON /DETECT/ ERR, SYSERR, ABORT ! 9: COMMON /CEXPRS/ LSTACK, STACK(620) ! 10: DATA IS /1H*/ ! 11: C ! 12: C ROUTINE PROCESSES A DATA STMT ! 13: C ! 14: 10 DECNT = 0 ! 15: 20 IF (ARDECL(K2,KK)) GO TO 30 ! 16: IF (.NOT.ERR) GO TO 30 ! 17: CALL ERROR1(19H ILLEGAL DECLARATOR, 19) ! 18: IF(.NOT.SYSERR) GOTO 260 ! 19: 30 IF (SYSERR) RETURN ! 20: C ! 21: C SET DECLARATOR USAGE AS VARIABLE; CHECK ITS NOT IN BLANK COMMON ! 22: C CANNOT BE INLABELLED COMMON IF THIS STMT NOT IN BLOCK DATA PGM ! 23: C FOUND A DECLARATOR ADD IT TO LIST OF ALL DECLS SO CAN CHECK ! 24: C TYPE OF ITS CORRESPONDING DATA-ITEM; ADD IN COUNT SO CAN ! 25: C CHECK NUMBER OF DECLS VS. NUMBER OF DATA-ITEMS ! 26: C KEEP TYPE INFO ON STACK; DECNT IS LENGTH OF STACK ! 27: C ! 28: I = IGATT1(KK,8) ! 29: IF (I.EQ.0) CALL SATT1(KK, 8, 10) ! 30: I = IGATT1(KK,2) ! 31: NN = IGATT1(NAME,8) ! 32: IF (I) 60, 60, 40 ! 33: C ! 34: C IF VARIABLE IN COMMON, CHECK TO SEE IF CAN LEGALLY APPEAR ! 35: C IN DATA STMT ! 36: C ! 37: 40 I = DSA(KK+2) ! 38: I = DSA(I+1) ! 39: CALL S5UNPK(DSA(I+4), S(1), 6) ! 40: IF (S(1).EQ.IS) GO TO 50 ! 41: C ! 42: C FOUND NO "*" SO ARE IN LABELLED COMMON ! 43: C ! 44: IF (NN.EQ.11) GO TO 70 ! 45: CALL ERROR1( ! 46: * 55H ILLEGAL TO INITIALIZE VARIABLE IN LABELLED COMMON HERE, ! 47: * 55) ! 48: GO TO 260 ! 49: C ! 50: C FOUND BLANK COMMON ! 51: C ! 52: 50 CALL ERROR1(48H ILLEGAL TO INITIALIZE VARIABLES IN BLANK COMMON, ! 53: * 48) ! 54: GO TO 260 ! 55: 60 IF (NN.NE.11) GO TO 70 ! 56: CALL ERROR1(33H DATA-ITEM NOT IN LABELLED COMMON, 33) ! 57: GO TO 260 ! 58: 70 I = IGATT1(KK,1) ! 59: CALL SATT1(KK, 5, 1) ! 60: NN = 1 ! 61: IF (IGATT1(KK,7).EQ.0) GO TO 75 ! 62: IF (STMT(K2-1).EQ.62) GO TO 75 ! 63: N = DSA(KK+2) ! 64: NN = DSA(N) ! 65: 75 CONTINUE ! 66: IF (DECNT+3.LE.LSTACK) GO TO 76 ! 67: CALL ERROR1(33H IN DATA, TABLE OVERFLOW OF STACK , 33 ) ! 68: GO TO 260 ! 69: 76 CONTINUE ! 70: STACK(DECNT+1) = MOD(I,8) ! 71: STACK(DECNT+2) = KK ! 72: STACK(DECNT+3) = NN ! 73: DECNT = DECNT + 3 ! 74: IF (STMT(K2).EQ.67) GO TO 100 ! 75: IF (STMT(K2).NE.68) GO TO 90 ! 76: PSTMT = K2 + 1 ! 77: IF (PSTMT.LT.NSTMT) GO TO 20 ! 78: 80 CALL ERROR1(15H ILLEGAL SYNTAX, 15) ! 79: RETURN ! 80: 90 CALL ERROR1(33H ILLEGAL PUNCTUATION IN DATA STMT, 33) ! 81: GO TO 260 ! 82: C ! 83: C FIND DATA-ITEMS; CHECK ITS TYPE VS. CORRESPONDING DECLARATOR ! 84: C SIGN .TRUE. IF DATA-ITEM PRECEEDED BY A SIGN ! 85: C REPL .TRUE. IF A REPLICATION FACTOR HAS ALREADY BEEN FOUND ! 86: C ! 87: 100 DATCNT = 0 ! 88: ERROR = .FALSE. ! 89: PSTMT = K2 + 1 ! 90: 110 IF (PSTMT.EQ.NSTMT) GO TO 80 ! 91: SIGN = .FALSE. ! 92: REPL = .FALSE. ! 93: NN = 1 ! 94: 120 IF (STMT(PSTMT).NE.60 .AND. STMT(PSTMT).NE.61) GO TO 130 ! 95: PSTMT = PSTMT + 1 ! 96: SIGN = .TRUE. ! 97: 130 IF (PSTMT.EQ.NSTMT) GO TO 80 ! 98: KK = GETTOK(PSTMT,K2) ! 99: IF (ERR) GO TO 80 ! 100: IF (KK.LT.6) GO TO 150 ! 101: 140 CALL ERROR1(18H ILLEGAL DATA-ITEM, 18) ! 102: GO TO 260 ! 103: 150 KK = KK + 1 ! 104: GO TO (200, 200, 160, 190, 190, 180), KK ! 105: C ! 106: C MUST MAKE SURE THAN AN INTEGER DATA-ITEM ISN'T A REPLICATION FACTO ! 107: C ! 108: 160 IF (REPL) GO TO 200 ! 109: IF(SIGN .OR. STMT(K2).NE.66) GOTO 200 ! 110: IF(TOKPNO(PSTMT,K2,NN)) GOTO 170 ! 111: CALL ERROR1(27H ILLEGAL REPLICATION FACTOR ,27) ! 112: NN = 1 ! 113: 170 REPL = .TRUE. ! 114: PSTMT = K2 + 1 ! 115: GO TO 120 ! 116: C ! 117: C CHECK LENGTH OF HOLLERITH DATA-ITEM; MUST FIT INTO INTEGER WORD ! 118: C ! 119: 180 IF (STMT(PSTMT)+2048.EQ.1 .OR. ERROR) GO TO 190 ! 120: CALL ERROR1( ! 121: * 53H WARNING - NH WITH N.GT.1 IS NOT A PORTABLE CONSTRUCT, 53) ! 122: ERROR = .TRUE. ! 123: C ! 124: C CHECK COMPLEX, HOLLERITH, AND LOGICAL DATA-ITEMS ARE UNSIGNED ! 125: C ! 126: 190 IF (SIGN) GO TO 140 ! 127: C ! 128: C CHECK COMPATIBLITY OF DATA-ITEMS WITH DECLARATORS ! 129: C NN IS REPLICATION FACTOR; ! 130: C ! 131: 200 IBR=0 ! 132: DO 220 I = 1,NN ! 133: IF (STACK(DATCNT+3).EQ.0) DATCNT = DATCNT + 3 ! 134: IF (DATCNT .GE. DECNT) GO TO 240 ! 135: STACK(DATCNT+3) = STACK(DATCNT+3) - 1 ! 136: IF (STACK(DATCNT+1).EQ.KK-1) GO TO 220 ! 137: IF ((STACK(DATCNT+1).NE.2 .OR. KK.NE.6) .AND. ! 138: * (STACK(DATCNT+1).NE.5 .OR. KK.NE.3)) GO TO 210 ! 139: CALL SATT1(STACK(DATCNT+2), 1, 5) ! 140: GO TO 220 ! 141: 210 IBR = 1 ! 142: 220 CONTINUE ! 143: IF(IBR .EQ. 1) CALL ERROR1(52 ! 144: 1H WARNING - DATA-ITEM IS INCOMPATIBLE WITH DECLARATOR ,52) ! 145: C ! 146: C CHECK FOR "," BETWEEN DATA-ITEMS ! 147: C ! 148: IF (STMT(K2).NE.68) GO TO 230 ! 149: PSTMT = K2 + 1 ! 150: GO TO 110 ! 151: C ! 152: C CHECK FOR ANOTHER SET OF DECLARATORS/DATA-ITEMS ! 153: C ! 154: 230 IF (STMT(K2).NE.67) GO TO 90 ! 155: IF (STACK(DATCNT+3).EQ.0) DATCNT = DATCNT + 3 ! 156: IF (DATCNT.EQ.DECNT) GO TO 250 ! 157: 240 CALL ERROR1(34H MISSING DECLARATORS OR DATA-ITEMS, 34) ! 158: IF (DATCNT.GE.DECNT) GO TO 260 ! 159: 250 PSTMT = K2 + 1 ! 160: IF (PSTMT.EQ.NSTMT) RETURN ! 161: IF (STMT(PSTMT).NE.68) GO TO 90 ! 162: PSTMT = PSTMT + 1 ! 163: IF (PSTMT.NE.NSTMT) GO TO 10 ! 164: GO TO 80 ! 165: C ! 166: C FLUSH TO "/," CONSTRUCT OR END OF STATEMEMT ! 167: C ! 168: 260 IF (PSTMT+1.GE.NSTMT) RETURN ! 169: IF (STMT(PSTMT).EQ.67 .AND. STMT(PSTMT+1).EQ.68) GO TO 270 ! 170: PSTMT = PSTMT + 1 ! 171: GO TO 260 ! 172: 270 PSTMT = PSTMT + 2 ! 173: IF (PSTMT.GE.NSTMT) RETURN ! 174: GO TO 10 ! 175: END
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.