![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to INSTMT.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 INSTMT.f CVS log | Up to [Research Unix] / researchv10no / cmd / pfort |
1.1 root 1: SUBROUTINE INSTMT(EOF, NCARD)
2: LOGICAL ILLEG, ILHOL, ILCONT
3: LOGICAL NEWRD, EOF, CONT, OPT, P1ERR
4: INTEGER PSTMT, CARD(80), OUTUT, BLK, STATE, HCOUNT, STMT
5: INTEGER SYMLEN, OUTUT2, OUTUT3, OUTUT4
6: DIMENSION IBR(5)
7: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
8: COMMON /OPTNS/ OPT(5), P1ERR
9: COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3,
10: * OUTUT4
11: COMMON /FACTS/ NAME, NOST, ITYP, IASF
12: DATA NEWRD /.TRUE./
13: DATA IBR(1), IBR(2), IBR(3), IBR(4), IBR(5) /1H*,1HC,1H.,1H0,1H /
14: DATA CARD(1) /1H /
15: C
16: C ROUTINE INPUTS AN ENTIRE FORTRAN STATEMENT. IT IS PASSED 1 CHAR
17: C PER ELEMENT IN THE ARRAY STMT.
18: C IN SHOULD BE CALLED AGAIN IF ERR IS TRUE.
19: C EACH CARD IS WRITTEN OUT BEFORE BEING PARSED.
20: C IN DEBLANKS CARDS USES THE VARIABLE STATE TO FIND
21: C HOLLERITHS:
22: C STATE = 0.....LOOK FOR BREAK CHAR
23: C 1.....HAVE BREAK CHAR AND NEED DIGIT
24: C 2.....HAVE DIGIT AND NEED DIGIT OR "H"
25: C 3....NEED TO SKIP OVER THESE CHARS, PART OF HOLLERITH
26: C NOTE: USE "90" AS AN END OF STMT MARKER
27: C
28: C NEWRD IS TRUE IF A NEW CARD IS NECESSARY; ELSE CARD IN BUFFER
29: C IS USED. EOF IS TRUE WHEN END-OF-FILE CARD ("." IN COL 1)
30: C IS READ NCARD GIVES # OF CARDS READ FOR THIS STMT
31: C
32: 10 NOST = NOST + 1
33: STATE = 0
34: NSTMT = 0
35: ILLEG = .FALSE.
36: ILCONT = .FALSE.
37: ILHOL = .FALSE.
38: NCARD = 0
39: CONT = .FALSE.
40: 20 IF (NEWRD) CALL IN(CARD, INUT)
41: IF (CARD(1).NE.IBR(2) .OR. CARD(2).NE.IBR(1)) GO TO 40
42: C
43: C DEAL WITH OPTIONS CARD
44: C
45: IF (CONT) GO TO 50
46: CALL INOPT(CARD)
47: 30 IF (OPT(4)) WRITE (OUTUT,99999) CARD
48: 99999 FORMAT (11X, 80A1)
49: NEWRD = .TRUE.
50: GO TO 20
51: 40 IF (CARD(1).NE.IBR(2)) GO TO 70
52: C
53: C DEAL WITH COMMENT CARD
54: C
55: IF (.NOT.CONT) GO TO 30
56: C
57: C HAVE COMPLETED STMT
58: C
59: 50 NEWRD = .FALSE.
60: NSTMT = NSTMT + 1
61: STMT(NSTMT) = 90
62: 60 IF (ILLEG) CALL ERROR1(
63: * 40H WARNING - NON-FORTRAN CHARACTER IGNORED, 40)
64: IF (ILHOL) CALL ERROR1(
65: * 46H WARNING - NON-FORTRAN CHARACTER IN HOLLERITH , 46)
66: IF (ILCONT) CALL ERROR1(
67: * 45H WARNING - NON-FORTRAN CONTINUATION CHARACTER, 45)
68: RETURN
69: 70 IF (CARD(1).NE.IBR(3)) GO TO 80
70: C
71: C HAVE EOF
72: C
73: IF (CONT) GO TO 50
74: EOF = .TRUE.
75: GO TO 60
76: 80 IF (CARD(6).EQ.IBR(4) .OR. CARD(6).EQ.IBR(5)) GO TO 100
77: C
78: C DEAL WITH CONTINUATION CARD
79: C
80: II = MAPCHR(CARD(6),ILCONT)
81: IF (CONT) GO TO 110
82: CALL ERROR1(40H WARNING - CONTINUATION NOT ALLOWED HERE, 40)
83: C
84: C FLUSH TO NEXT NONCONTINUATION CARD
85: C
86: 90 IF (OPT(4)) WRITE (OUTUT,99998) NOST, CARD
87: 99998 FORMAT (1H , I5, 5X, 80A1)
88: CALL IN(CARD, INUT)
89: IF (CARD(1).NE.IBR(1) .AND. CARD(1).NE.IBR(2) .AND.
90: * CARD(1).NE.IBR(3) .AND. CARD(6).NE.IBR(4) .AND.
91: * CARD(6).NE.IBR(5)) GO TO 90
92: NEWRD = .FALSE.
93: GO TO 10
94: C
95: C DEAL WITH A NON-CONTINUATION CARD
96: C
97: 100 IF (CONT) GO TO 50
98: C DEAL WITH A LEGAL CONTIN OR NONCONTIN CARD
99: 110 NCARD = NCARD + 1
100: IF (NCARD.LT.21) GO TO 120
101: CALL ERROR1(33H WARNING - TOO MANY CONTINUATIONS, 33)
102: GO TO 90
103: 120 IF (OPT(4)) WRITE (OUTUT,99998) NOST, CARD
104: NEWRD = .TRUE.
105: BLK = 0
106: IF (NSTMT.NE.0) GO TO 150
107: DO 130 I=1,5
108: NSTMT = NSTMT + 1
109: STMT(NSTMT) = MAPCHR(CARD(I),ILLEG)
110: 130 CONTINUE
111: 140 I = 7
112: GO TO 180
113: 150 DO 160 I=1,5
114: IF (MAPCHR(CARD(I),ILLEG).NE.69) GO TO 170
115: 160 CONTINUE
116: GO TO 140
117: 170 CALL ERROR1(40H WARNING - ILLEGAL LABEL WILL BE IGNORED, 40)
118: GO TO 140
119: 180 IF (I.LE.72) GO TO 200
120: C
121: C AFTER TRANSLATE CARD CHECK FOR BLANK CARD
122: C AND GO BACK FOR A CONTINUATION CARD
123: C
124: IF (BLK.NE.66) GO TO 190
125: CALL ERROR1(33H WARNING - BLANK CARD ENCOUNTERED, 33)
126: GO TO 90
127: 190 CONT = .TRUE.
128: GO TO 20
129: 200 IF (STATE.NE.3) GO TO 210
130: C
131: C STATE 3 --ARE PROCESSING A HOLLERITH
132: C
133: HCOUNT = HCOUNT - 1
134: KK = MAPCHR(CARD(I),ILHOL)
135: IF (HCOUNT.EQ.0) STATE = 0
136: GO TO 290
137: 210 NSTMT = NSTMT + 1
138: STMT(NSTMT) = MAPCHR(CARD(I),ILLEG)
139: IF (STMT(NSTMT).NE.69) GO TO 220
140: C
141: C BLANK ENCOUNTERED AND DELETED
142: C
143: BLK = BLK + 1
144: NSTMT = NSTMT - 1
145: GO TO 290
146: 220 KK = STATE + 1
147: GO TO (280, 260, 230), KK
148: C
149: C STATE 2--SKIP OVER LEADING DIGIT STRING; LOOK FOR H
150: C
151: 230 IF (STMT(NSTMT).LE.9) GO TO 290
152: IF (STMT(NSTMT).NE.37) GO TO 270
153: C
154: C PROCESS HOLLERITH COUNT
155: C
156: STMT(NSTMT) = -STMT(NSTMT)
157: STATE = 3
158: KK = NSTMT - KST
159: I10 = 1
160: HCOUNT = 0
161: DO 240 K=1,KK
162: JJ = NSTMT - K
163: HCOUNT = HCOUNT + I10*STMT(JJ)
164: I10 = I10*10
165: 240 CONTINUE
166: STMT(KST) = HCOUNT - 2048
167: NSTMT = KST
168: IF (HCOUNT.LE.0) GO TO 250
169: GO TO 290
170: C
171: C AVOID THE 0H CONSTRUCTION
172: C
173: 250 CALL ERROR1(44H WARNING - 0H ILLEGAL HOLLERITH CONSTRUCTION, 44)
174: STATE = 0
175: GO TO 290
176: C
177: C STATE 1--LOOK FOR START OF DIGIT STRING BEFORE H
178: C
179: 260 IF (STMT(NSTMT).GT.9) GO TO 270
180: STATE = 2
181: KST = NSTMT
182: GO TO 290
183: C
184: C CHECK FOR NESTED SPECIAL HEADING CHARS
185: C
186: 270 STATE = 0
187: 280 IF ((STMT(NSTMT).LT.65) .OR. (STMT(NSTMT).GT.68)) GO TO 290
188: STATE = 1
189: 290 I = I + 1
190: GO TO 180
191: END
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.