![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to FORMAT.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 FORMAT.f CVS log | Up to [Research Unix] / researchv10no / cmd / pfort |
1.1 root 1: SUBROUTINE FORMAT
2: INTEGER STMT, PSTMT
3: LOGICAL TOKPNO, SIGN, ERROR
4: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
5: C
6: C ROUTINE PROCESSES FORMAT STMT
7: C FORMAT (Q1 T1 Z1 T2 Z2 ... TN Q2)
8: C Q1,Q2 ARE EMPTY OR ARE SEPARARTERS
9: C T1,T2 ETC. ARE FORMAT-ITEMS
10: C Z1,Z2, ETC. ARE SEPARATERS
11: C CHECKS FOR <= 2 LEVELS OF PARENTHESES
12: C
13: ERROR = .FALSE.
14: ICNT = 0
15: C
16: C "("
17: C
18: IF (STMT(PSTMT).EQ.65) GO TO 30
19: 10 CALL ERROR1(20H ILLEGAL PUNCTUATION, 20)
20: C
21: C SEARCH FOR FORMAT ITEMS
22: C
23: 20 RETURN
24: 30 ICNT = ICNT + 1
25: IF (ICNT.GT.2) CALL ERROR1(28H TOO MANY PARENTHESES LEVELS, 28)
26: PSTMT = PSTMT + 1
27: C
28: C LOOK FOR Q1
29: C
30: CALL SEPAR(I)
31: C TAKES CARE OF FORMAT()
32: IF (STMT(PSTMT).EQ.62) GO TO 180
33: IF (STMT(PSTMT-1).EQ.68) CALL ERROR1(25H ILLEGAL PUNCTUATION (, ,
34: * 25)
35: 40 IF (STMT(PSTMT).EQ.65) GO TO 30
36: IF (PSTMT.GE.NSTMT) GO TO 10
37: SIGN = .FALSE.
38: C
39: C SEARCH FOR REPEAT FACTER (POSITIVE INTEGER)
40: C
41: IF (TOKPNO(PSTMT,K2,N)) GO TO 70
42: C
43: C HOLLERITH STRINGS
44: C
45: IF (STMT(PSTMT).LT.0) GO TO 120
46: C
47: C "-" IN P SCALING FORMAT-ITEM
48: C
49: IF (STMT(PSTMT).NE.61) GO TO 50
50: SIGN = .TRUE.
51: PSTMT = PSTMT + 1
52: 50 IF (PSTMT.GE.NSTMT) GO TO 10
53: C
54: C LOOK FOR <INT> IN PSCALING FORMAT-ITEM
55: C P SCALING FORMAT-ITEM
56: C ( - ) <INTEGER> P REPEAT (A,I,L) <WIDTH> . <INT>
57: C
58: CALL NEXTOK(PSTMT, K2, K)
59: C
60: C CHECK FOR USE OF "-" WITH NON P-SCALING CONSTRUCTS
61: C
62: IF (K.NE.1 .AND. SIGN) GO TO 100
63: IF (K.EQ.1) GO TO 60
64: N = STMT(PSTMT)
65: GO TO 90
66: 60 SIGN = .TRUE.
67: PSTMT = K2
68: N = STMT(PSTMT)
69: GO TO 80
70: C
71: C LOOK FOR PART OF FORMAT-ITEM AFTER REPEAT FACTOR
72: C
73: 70 PSTMT = K2
74: N = STMT(PSTMT)
75: C
76: C "("
77: C
78: IF (N.EQ.65) GO TO 30
79: C
80: C "X"
81: C
82: IF (N.EQ.53) GO TO 120
83: C
84: C "P"
85: C
86: 80 IF (N.EQ.45) GO TO 130
87: IF (SIGN) GO TO 100
88: C
89: C A,I,L
90: C
91: 90 IF (N.EQ.30 .OR. N.EQ.38 .OR. N.EQ.41) GO TO 110
92: C
93: C D,E,F,G
94: C
95: IF (N.GE.33 .AND. N.LE.36) GO TO 150
96: 100 CALL ERROR1(20H ILLEGAL FORMAT ITEM, 20)
97: GO TO 20
98: C
99: C A,I,L FOUND. LOOK FOR <WIDTH>
100: C
101: 110 IF (PSTMT+1.GE.NSTMT) GO TO 10
102: PSTMT = PSTMT + 1
103: IF (.NOT.TOKPNO(PSTMT,K2,I)) GO TO 100
104: IF (N.NE.30 .OR. I.EQ.1 .OR. ERROR) GO TO 160
105: CALL ERROR1(48H WARNING - A FORMAT ITEM NOT PORTABLE FOR N.GT.1,
106: * 48)
107: ERROR = .TRUE.
108: GO TO 160
109: C
110: C SKIP TO NEXT CHAR IN X OR HOLLERITH
111: C
112: 120 PSTMT = PSTMT + 1
113: GO TO 170
114: C
115: C LOOK FOR CONSTRUCT FOLLOWING THE P. CAN BE A REPEAT
116: C
117: 130 IF (PSTMT+1.GE.NSTMT) GO TO 10
118: PSTMT = PSTMT + 1
119: IF (STMT(PSTMT).GT.9 .OR. STMT(PSTMT).LT.0) GO TO 140
120: CALL NEXTOK(PSTMT, K2, K)
121: IF (K.NE.1) GO TO 10
122: PSTMT = K2
123: C
124: C AFTER D,E,F,G FIND <WIDTH> . <INT>
125: C
126: 140 IF (STMT(PSTMT).LT.33 .OR. STMT(PSTMT).GT.36) GO TO 10
127: 150 IF (PSTMT+1.GE.NSTMT) GO TO 10
128: PSTMT = PSTMT + 1
129: IF (.NOT.TOKPNO(PSTMT,K2,N)) GO TO 100
130: IF (STMT(K2).NE.64) GO TO 100
131: IF (K2+1.GE.NSTMT) GO TO 10
132: PSTMT = K2 + 1
133: CALL NEXTOK(PSTMT, K2, K)
134: IF (K.NE.1) GO TO 100
135: 160 PSTMT = K2
136: C
137: C FINISHED A FORMAT-ITEM
138: C LOOK FOR SEPARATER OR ")"
139: C
140: 170 IF (STMT(PSTMT).NE.62) GO TO 210
141: 180 ICNT = ICNT - 1
142: IF (ICNT.LT.0) GO TO 190
143: IF (PSTMT+1.LT.NSTMT) GO TO 200
144: IF (ICNT.EQ.0) GO TO 20
145: 190 CALL ERROR1(28H ILLEGAL PARENTHESES NESTING, 28)
146: GO TO 20
147: 200 PSTMT = PSTMT + 1
148: GO TO 170
149: 210 CALL SEPAR(I)
150: IF (I.EQ.0) CALL ERROR1(24H MISSING FIELD SEPARATOR, 24)
151: IF (STMT(PSTMT).NE.62) GO TO 40
152: IF (STMT(PSTMT-1).EQ.68) CALL ERROR1(25H ILLEGAL PUNCTUATION ,) ,
153: * 25)
154: GO TO 180
155: END
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.