-
Notifications
You must be signed in to change notification settings - Fork 0
/
ncscan.f
193 lines (175 loc) · 7 KB
/
ncscan.f
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C M.B. This code is largely as generated by the SFTRAN3 (Structured
C FORTRAN) pre-processor. SFTRAN3 was used to allow coding
C FORTRAN in a more easily understood syntax including the use
C of structures, such as IF-THEN-ELSE-END{IF] and DO-END[DO],
C when the FORTRAN compiler in use did not make those tools
C available. The pre-processed output code, such as that
C below, used GOTOs to implement the functionality provided by
C IF-ENDIF and DO-ENDDO, and is less easily read and
C understood.
C
C In addition it was found, ca. July 2019, that the SFTRAN3
C output file ncscan.f, on which this file is based, was not
C compiled correctly by the GFORTRAN compiler, whle the G77
C compiler did compile ncscan.f correctly.
C
C In the course of debugging that issue, this file was created,
C which can be compiled with or without the ARGRTN CPP macro.
C Refer to the associated Makefile for details of how to do
C that, but the important things to note are that
C
C 1) If the ARGRTN CPP macro ***IS NOT*** defined, then the
C GFORTRAN compiler ***WILL NOT*** compile this code
C correctly.
C
C 2) If the ARGRTN CPP macro ***IS*** defined, then the
C GFORTRAN compiler ***WILL*** compile this code correctly.
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
LOGICAL FUNCTION NCSCAN (IFUNC, STRING, N)
C Performs scanning functions on the character string in
C STMT() in COMMON /CC02/.
C Does not change contents of STMT().
C May change values of NS in /C02/ and CC, CCMORE and MORE in /C04/
C Operation performed is selected by IFUNC. Only the case of IFUNC =
C 2 is valid here; the subr will return immediately with NCSCAN =
C .FALSE. if MORE is false on entry.
C
C IFUNC=2:Test for match of (STRING(I),I=1,N) with (STMT(I),I =
C CCMORE, CCMORE+N-1). The test uses subprogram NNCMPR that
C treats upper and lower case instances of the same letter
C as equal. If match, set NCSCAN = true, then search
C starting at CCMORE + N for next non-blank and set MORE
C and CCMORE and NS as when IFUNC = 1.
C If no match set NCSCAN = false.
C
C Common Block Variables used
C ------------ --------------
C C02 NS End of current statement in STMT().
C Value of NS may be reduced by this
C subr if statement is found to end
C with blanks.
C
C CC02 STMT() Current statement being analysed.
C
C C04 CC, CCMORE, LCCHR, MORE
C
C CC04 COMCHR(2) This is the inline comment token. Its
C length is 1 or 2 as given by LCCHR.
C
C ------------------------------------------------------------------
C
C SUBROUTINEs called: NNCMPR
C ------------------------------------------------------------------
INTEGER CCNEXT, CCSAVE
CHARACTER STRING(*)
LOGICAL NNCMPR
INTEGER NS
CHARACTER STMT(1334)
INTEGER BYTE,CC,CCMORE,LCCHR
CHARACTER*1 COMCHR(2)
LOGICAL MORE
COMMON /C02/ NS
COMMON /CC02/ STMT
COMMON /C04/ BYTE,CC,CCMORE,LCCHR,MORE
COMMON /CC04/ COMCHR
C ------------------------------------------------------------------
C MAIN LOGIC
C
C Lobotomized for testing: only IFUNC.EQ.2 is supported
if (IFUNC.NE.2) STOP 'Bad value for IFUNC'
GO TO 30002
C Jump target from below for RETURN
20009 RETURN
C ------------------------------------------------------------------
C
C PROCEDURE (FIND)
C TESTS FOR MATCH BETWEEN GIVEN STRING AND THE NEXT N BYTES
C OF THE CURRENT STATEMENT.
C
C OUTPUTS:
C IF (MORE .AND. FIND) THEN
C NCSCAN = .TRUE.
C CC .=. BYTE WHERE SEARCH FOR MATCH BEGAN IN CURRENT STATEMEN
C MORE, CCMORE, & NS AS PER PROC (SCAN FOR NON-BLANK)
C ELSE
C NCSCAN = .FALSE.
C CC, MORE, CCMORE, & NS UNCHANGED
C ENDIF
C
30002 NCSCAN = MORE .AND. (CCMORE+N-1.LE.NS)
* .AND. NNCMPR(STRING,1,STMT,CCMORE,N)
# ifndef ARGRTN
C If no match -> 20014 (below) -> 20009 (above) -> RETURN
C N.B. this path, when compiled by GFORTRAN when the ARGRTN macro
C above ***IS NOT*** defined, causes this NCSCAN function to
C return .TRUE., even though it is .FALSE.
IF (.NOT.(NCSCAN)) GO TO 20014
# else
C If no match simply RETURN, bypassing GOTO paths created by SFTRAN3
C N.B. this path, when compiled by GFORTRAN when the ARGRTN macro
C above ***IS*** defined ,caused this NCSCAN to function to
C correctly return .FALSE.
IF (.NOT.(NCSCAN)) RETURN
# endif
C Start update of CCMORE and other pointers after scan for next
C non-blank character in STMT
CC=CCMORE
CCNEXT=CCMORE+N
C Jump to scan below to find next token
GO TO 30005
C Scan below jumps back to here (20015) -> 20009 (above) -> RETURN
20015 CONTINUE
20014 GO TO 20009
C
C ------------------------------------------------------------------
C
C PROCEDURE (SCAN FOR NON-BLANK)
C
C GIVEN THAT CCNEXT.LE.NS, START AT STMT[CCNEXT] AND SEARCH UNTIL
C EITHER A NON-BLANK IS FOUND OR THE STRING IS EXHAUSTED. IF A
C NON-BLANK IS FOUND AND IT IS NOT THE INLINE-COMMENT CHARACTER,
C 'MORE' IS SET TRUE AND 'CCMORE' IS ITS POSITION. OTHERWISE,
C 'MORE' IS SET FALSE AND 'NS' IS SET TO THE STRING LENGTH.
C
C INPUTS:
C NS = LENGTH OF 'STMT' STRING
C CCNEXT = BYTE OF 'STMT' AT WHICH TO BEGIN SEARCH FOR NON-BLANK
C
C DECISION TABLE:
C
C CCNEXT .LE. NS * F T T T
C STMT BLANK FROM CCNEXT ONWARD * T F F
C 1ST NON-BLANK IS COMMENT CHAR * T F
C *
C *************************************************************
C *
C MORE . . . . . . . . . . . . * .F. .F. .F. .T.
C CCMORE = LOC OF NEXT NON-BLANK * N/C N/C N/C CARD COL
C NS . . . . . . . . . . . . * N/C CCNEXT-1 N/C N/C
C
C N/C => NO CHANGE
C
C
30005 MORE=.FALSE.
IF (CCNEXT .GT. NS) GO TO 31005
CCSAVE = CCNEXT
DO 20057 CCNEXT = CCSAVE, NS
IF (STMT(CCNEXT) .NE. ' ') GO TO 20056
20057 CONTINUE
NS = MAX(CCSAVE-1,1)
GO TO 31005
C
20056 IF(STMT(CCNEXT) .NE. COMCHR(1))THEN
MORE = .TRUE.
ELSEIF(LCCHR .EQ. 2)THEN
IF(CCNEXT .EQ. NS)THEN
MORE = .TRUE.
ELSEIF(STMT(CCNEXT+1) .NE. COMCHR(2))THEN
MORE = .TRUE.
END IF
END IF
IF (MORE) CCMORE = CCNEXT
C Jump back to line above where jump to 30005 occured
31005 GO TO 20015
END