![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to DOSPEC.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 DOSPEC.f CVS log | Up to [Research Unix] / researchv10no / cmd / pfort |
1.1 ! root 1: SUBROUTINE DOSPEC(KK, K2, LOG) ! 2: INTEGER STMT, PSTMT, DOPT, DOLIST, LOOKUP ! 3: LOGICAL SYSERR, ABORT, DOVAR, ERR, TOKPNO, LOG ! 4: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 5: COMMON /LISTDO/ LPT, LEN, LS(64) ! 6: COMMON /DOS/ DOPT, LDO, DOLIST(192) ! 7: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 8: COMMON /DETECT/ ERR, SYSERR, ABORT ! 9: C ! 10: C ROUTINE RECOGNIZES DO-SPECIFICATION CONSTRUCT ! 11: C DOLIST ARRAY IS DO STACK USED TO CHECK NESTING; 6 WORD ENTRY ! 12: C WORD 1-CURRENT STMT NO ! 13: C WORD 2-INDEX OF LABEL IN DSA ! 14: C WORD 3-INDEX OF DO CONTROL VARIABLE IN DSA ! 15: C WORD 4-6,-INDICES OF LIMITS IN DSA OR 0 FOR CONSTANT LIMITS ! 16: C LS ARRAY IS IMPLICIT DO STACK- IN EACH ENTRY IS SAME DATA ! 17: C AS WORDS 3-6 OF DOLIST ENTRIES. ! 18: C ! 19: IF (.NOT.LOG) GO TO 10 ! 20: IF (LPT.LE.1) GO TO 20 ! 21: LPT = LPT - 4 ! 22: LS(LPT) = 0 ! 23: LS(LPT+1) = 0 ! 24: LS(LPT+2) = 0 ! 25: LS(LPT+3) = 0 ! 26: GO TO 40 ! 27: 10 IF (DOPT.LE.LDO-11) GO TO 30 ! 28: 20 CALL ERROR1(20H DO NESTING TOO DEEP, 20) ! 29: GO TO 190 ! 30: 30 DOPT = DOPT + 6 ! 31: DOLIST(DOPT) = NOST ! 32: DOLIST(DOPT+1) = KK ! 33: DOLIST(DOPT+2) = 0 ! 34: DOLIST(DOPT+3) = 0 ! 35: DOLIST(DOPT+4) = 0 ! 36: DOLIST(DOPT+5) = 0 ! 37: C ! 38: C DO CONTROL VARIABLE MUST BE INTEGER, SCALAR VARIABLE ! 39: C ! 40: 40 IF (PSTMT.LT.NSTMT) GO TO 60 ! 41: 50 CALL ERROR1(35H ILLEGAL SYNTAX IN DO SPECIFICATION, 35) ! 42: GO TO 190 ! 43: 60 CALL NEXTOK(PSTMT, K2, K) ! 44: IF (K.NE.0) GO TO 50 ! 45: K = LOOKUP(K2,.FALSE.) ! 46: IF (SYSERR) GO TO 180 ! 47: I1 = IGATT1(K,1) ! 48: IF (I1.GT.0) GO TO 70 ! 49: I1 = 1 ! 50: IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2 ! 51: CALL SATT1(K, 1, I1) ! 52: 70 I2 = IGATT1(K,7) ! 53: I3 = IGATT1(K,8) ! 54: IF (MOD(I1,8).NE.2 .OR. I2.NE.0) GO TO 220 ! 55: IF (I3.NE.0) GO TO 80 ! 56: I3 = 10 ! 57: CALL SATT1(K, 8, 10) ! 58: 80 IF (I3.NE.10) GO TO 220 ! 59: CALL SATT1(K, 5, 1) ! 60: IF (DOVAR(K)) CALL ERROR1( ! 61: * 57H ILLEGAL TO CHANGE VALUE OF CONTROL VARIABLE OR DO LIMITS, ! 62: * 57) ! 63: I3 = IGATT1(K,2) ! 64: IF (I3.EQ.1) CALL ERROR1(37H WARNING - CONTROL VARIABLE IN COMMON, ! 65: * 37) ! 66: IF (K.EQ.NAME) CALL ERROR1( ! 67: * 49H WARNING - FUNCTION NAME USED AS CONTROL VARIABLE, 49) ! 68: IF (.NOT.LOG) GO TO 90 ! 69: LS(LPT) = K ! 70: GO TO 100 ! 71: 90 DOLIST(DOPT+2) = K ! 72: C ! 73: C FIND AN = ! 74: C ! 75: 100 IF (STMT(K2).NE.63) GO TO 50 ! 76: C ! 77: C DO-LIMITS LIMS COUNTS NUMBER OF LIMITS; THESE MUST BE INTEGER ! 78: C SCALAR VARIABLES OR POSITIVE INTEGER CONSTANTS ! 79: C ! 80: LIMS = 0 ! 81: 110 PSTMT = K2 + 1 ! 82: IF (PSTMT.GE.NSTMT) GO TO 50 ! 83: IF (.NOT.TOKPNO(PSTMT,K2,K)) GO TO 120 ! 84: LIMS = LIMS + 1 ! 85: GO TO 170 ! 86: 120 CALL NEXTOK(PSTMT, K2, K) ! 87: IF (K.NE.0) GO TO 210 ! 88: K = LOOKUP(K2,.FALSE.) ! 89: IF (SYSERR) GO TO 180 ! 90: LIMS = LIMS + 1 ! 91: IF (.NOT.LOG) GO TO 130 ! 92: IF (LS(LPT).EQ.K) CALL ERROR1(17H ILLEGAL DO LIMIT, 17) ! 93: I1 = LPT + LIMS ! 94: LS(I1) = K ! 95: GO TO 140 ! 96: 130 IF (DOLIST(DOPT+2).EQ.K) CALL ERROR1(17H ILLEGAL DO LIMIT, 17) ! 97: I1 = DOPT + 2 + LIMS ! 98: DOLIST(I1) = K ! 99: 140 I1 = IGATT1(K,1) ! 100: I2 = IGATT1(K,7) ! 101: I3 = IGATT1(K,8) ! 102: IF (I3.NE.0) GO TO 150 ! 103: CALL SATT1(K, 8, 10) ! 104: I3 = 10 ! 105: 150 IF (I3.NE.10) GO TO 50 ! 106: IF (I1.GT.0) GO TO 160 ! 107: I1 = 1 ! 108: IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2 ! 109: CALL SATT1(K, 1, I1) ! 110: 160 IF (MOD(I1,8).NE.2 .OR. I2.NE.0) GO TO 210 ! 111: C ! 112: C CHECK FOR END OF STMT ! 113: C ! 114: 170 IF (K2.LT.NSTMT .AND. STMT(K2).NE.62) GO TO 200 ! 115: C ! 116: C IF THERE ARE NO MORE CHARS, WE ARE DONE WITH THIS STMT; ! 117: C THERE MUST BE AT LEAST 2 AND NO MORE THAN 3 LIMITS IN DO ! 118: C ! 119: IF (LIMS.LE.1) GO TO 230 ! 120: 180 RETURN ! 121: 190 ERR = .TRUE. ! 122: GO TO 180 ! 123: C ! 124: C CHECK FOR A "," MUST FIND HERE ! 125: C ! 126: 200 IF (STMT(K2).NE.68) GO TO 50 ! 127: IF (LIMS.GE.3) GO TO 230 ! 128: GO TO 110 ! 129: 210 CALL ERROR1(47H DO LIMIT NOT INTEGER SCALAR VAR OR POS INTEGER, ! 130: * 47) ! 131: GO TO 190 ! 132: 220 CALL ERROR1(36H CONTROL VARIABLE NOT INTEGER SCALAR, 36) ! 133: GO TO 190 ! 134: 230 CALL ERROR1(18H ILLEGAL DO LIMITS, 18) ! 135: GO TO 190 ! 136: END
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.