![[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.