NLSL: strutl1.f90 Source File

NLSL

- Main Page
- Modules
- Data Types List
- Files

- File List
- File Members

strutl1.f90
Go to the documentation of this file.
1 c NLSL Version 1.9.0 beta 2/9/15
2 c----------------------------------------------------------------------
3 c> @file strutl1.f90
4 c> I/O UTILITY ROUTINES FOR NLS COMMAND INTERPRETER
5 c>
6 c> Contains four functions and two subroutines:
7 c>
8 c> getlin -- issue a prompt, retrieve a line from command stream *
9 c>
10 c> gettkn -- extract a token from the given line (subroutine)
11 c>
12 c> ungett -- replace a token at the line's beginning (subroutine)
13 c>
14 c> ftoken -- returns a real number
15 c>
16 c> itoken -- returns an integer number
17 c>
18 c> indtkn -- returns an index, i.e., a parenthesized number *
19 c>
20 c> * Note: two of these routines use module stdio. Subroutine touppr
21 c> and function itrim were moved into strutl2.f90 because they have
22 c> more general utility and a different set of dependencies.
23 c>----------------------------------------------------------------------
24
25
26 c----------------------------------------------------------------------
27 c =========================
28 c function GETLIN
29 c =========================
30 c----------------------------------------------------------------------
31 function getlin( line )
32 c> @brief issue a prompt and retreive a line from command stream
33 c
34 use stdio
35 implicit none
36 c
37 logical getlin
38 c
39 integer ioerr
40 character*80 line
41 c
42 call wpoll
43 c
44 if(lucmd.eq.luttyi) call lprmpt
45 read (lucmd,1001,iostat=ioerr) line
46 c
47 c -- Echo line if required
48 c
49 if (ioerr.eq.0 .and. lucmd.ne.luttyi .and. luecho.ne.0)
50 # write(luecho,1001) line
51 if (luecho.ne.0.and.luout.eq.lulog) write(lulog,1001) line
52 getlin=ioerr.eq.0
53 return
54 c
55 1001 format(a)
56 end function getlin
57
58 c------------------------------------------------------------------------
59 c ===================
60 c subroutine GETTKN
61 c ===================
62 c
63 c> @brief
64 c> Written for free-form input of parameters for slow-motional
65 c> calculations. Returns a token consisting of nonseparator
66 c> characters (separators are space, tab, and ',') with all control
67 c> @details
68 c> characters filtered out.
69 c> Special cases: '(', ')', '=', '*', and end-of-line, which are
70 c> returned as single-character tokens.
71 c
72 c ------------------------------------------------------------------------
73 c
74 subroutine gettkn(line,token,lth)
75 implicit none
76 integer lth
77 c
78 integer LINLTH
79 parameter(linlth=80)
80 c
81 character line*80,token*30,chr*1
82 c
83 integer i,j,ichr,ichar
84 c
85 c *** Function definitions
86 c
87 logical issepr,is1tok,isctrl,istab
88 isctrl(chr) = ichar(chr).lt.32
89 istab(chr) = ichar(chr).eq.9
90 issepr(chr) = chr.eq.' '.or. ichar(chr).eq.9 .or. chr.eq.','
91 # .or.chr.eq.';'
92 is1tok(chr) = chr.eq.'('.or.chr.eq.')'.or.chr.eq.'*'
93 # .or.chr.eq.'='
94 c ***
95 c
96 c------------------------------------------
97 c Find the next non-whitespace character
98 c------------------------------------------
99 i=0
100 2 i=i+1
101 3 chr=line(i:i)
102 c
103 c -------------------------
104 c skip control characters
105 c -------------------------
106 if (isctrl(chr).and. .not.istab(chr)) then
107 line(i:)=line(i+1:)
108 go to 3
109 end if
110 c
111 if (issepr(chr).and. i.lt.linlth) goto 2
112 c
113
114 if (i.ge.linlth) then
115 lth=0
116 token=' '
117 return
118 end if
119 c
120 c -----------------------------------
121 c Check for single-character tokens
122 c -----------------------------------
123 if (is1tok(chr)) then
124 token=chr
125 lth=1
126 line=line(i+1:)
127 return
128 end if
129 c
130 c----------------------------------------------------------------
131 c Place the next continuous string of characters in the token
132 c (stop at whitespace, punctuation, and single-character tokens)
133 c Shorten the rest of the line accordingly
134 c----------------------------------------------------------------
135 j=i
136 4 j=j+1
137 5 chr=line(j:j)
138 c
139 c -----------------------
140 c Skip control characters
141 c -----------------------
142 if (isctrl(chr).and. .not.istab(chr)) then
143 line(j:)=line(j+1:)
144 go to 5
145 end if
146 c
147 if ( issepr(chr) .or. is1tok(chr) ) then
148 token=line(i:j-1)
149 lth=j-i
150 line=line(j:)
151 return
152 else
153 go to 4
154 end if
155 end subroutine gettkn
156
157 c----------------------------------------------------------------------
158 c =========================
159 c subroutine UNGETT
160 c =========================
161 c Replaces given token at the beginning of the given line
162 c (Oh for the string functions of C..)
163 c----------------------------------------------------------------------
164 subroutine ungett(token,lth,line)
165 implicit none
166 character line*80,tmplin*80,token*30
167 integer lth
168 if (lth.gt.0.and.lth.lt.80) then
169 tmplin=line
170 line=token(:lth) // tmplin
171 end if
172 return
173 end subroutine ungett
174
175 c----------------------------------------------------------------------
176 c =========================
177 c function FTOKEN
178 c =========================
179 c Decodes a token into a floating point number
180 c----------------------------------------------------------------------
181 function ftoken( token,lth,val )
182 implicit none
183 character token*30,tkn*30,tmptkn*30,chr*1
184 integer i,lth,idot,ibrk
185 double precision val
186 logical ftoken
187 c
188 c *** Function definitions --- these don't work with every FORTRAN
189 c implementation.
190 c
191 logical isdot,isexp,isdig
192 isdot(chr)=chr.eq.'.'
193 isexp(chr)=(chr .eq. 'd' .or. chr .eq. 'D') .or.
194 1 (chr .eq. 'e' .or. chr .eq. 'E')
195 isdig(chr)=chr.ge.'0' .and. chr.le.'9'
196 c ***
197 c----------------------------------------------------------------------
198 c
199 tkn=token
200 idot=0
201 ibrk=0
202 c
203 c----------------------------------------------------------------------
204 c Find where a '.' is needed in the string
205 c (this is to overcome the implied decimal used by some compilers)
206 c
207 c Also, check for illegal characters (this is for FORTRAN compilers
208 c that don't return an error when non-numeric characters
209 c are encountered in the read.)
210 c----------------------------------------------------------------------
211 do 10 i=1,lth
212 chr=tkn(i:i)
213 if (isdot(chr)) then
214 idot=i
215 else if (isexp(chr)) then
216 ibrk=i
217 else if (.not. isdig(chr).and.chr.ne.'-') then
218 go to 13
219 end if
220 10 continue
221 c
222 if (idot.eq.0) then
223 if (ibrk .eq. 0) then
224 tkn=tkn(:lth)//'.'
225 else
226 tmptkn=tkn(ibrk:)
227 tkn=tkn(:ibrk-1) // '.' // tmptkn
228 end if
229 lth=lth+1
230 end if
231
232 read(tkn,1000,err=13) val
233 ftoken=.true.
234 return
235 c
236 13 ftoken=.false.
237 return
238 c
239 1000 format(bn,f20.10)
240 end function ftoken
241
242 c----------------------------------------------------------------------
243 c =========================
244 c function ITOKEN
245 c =========================
246 c----------------------------------------------------------------------
247 function itoken( token,lth,ival )
248 implicit none
249 character*30 token
250 integer lth,ival
251 logical itoken
252 c
253 c..................................................
254 c read (token,1000,err=13) ival
255 c 12 itoken=.true.
256 c return
257 c
258 c 13 itoken=.false.
259 c return
260 c
261 c 1000 format(bn,i20)
262 c..................................................
263 c
264 double precision fval
265 logical ftoken
266 external ftoken
267 itoken=ftoken(token,lth,fval)
268 ival=fval
269 return
270 end function itoken
271
272 c----------------------------------------------------------------------
273 c =========================
274 c function INDTKN
275 c =========================
276 c
277 c Looks for a secondary index specified by the series of tokens
278 c '(' <n> { ')' } or '(' '*' { ')' }. Returns n if found, -1 if
279 c '*' was specified, and 0 if no index was specified
280 c----------------------------------------------------------------------
281 function indtkn(line)
282 c
283 use stdio
284 implicit none
285 c
286 integer indtkn
287 character line*80,token*30
288 c
289 integer ival,lth
290 logical wldcrd
291 c
292 logical itoken
293 external itoken
294 c
295 c######################################################################
296 c
297 call gettkn(line,token,lth)
298 c
299 c----------------------------------------------------------------------
300 c Look for parenthesis indicating a second index will be specified
301 c----------------------------------------------------------------------
302 if (token.eq.'(') then
303 call gettkn(line,token,lth)
304 c
305 c----------------------------------------------------------------------
306 c Check for a valid index: '*' or an integer in range
307 c----------------------------------------------------------------------
308 wldcrd=token.eq.'*'
309 c
310 c *** Empty '()': index is 0
311 if (token.eq.')') then
312 indtkn=0
313 else
314 c *** Wildcard: return -1
315 if (wldcrd) then
316 indtkn=-1
317 else
318 c *** Check for legal number
319 c
320 if (itoken(token,lth,ival)) then
321 indtkn=ival
322 else
323 c *** Illegal index
324 c
325 write(luttyo,1000) token(:lth)
326 indtkn=0
327 end if
328 end if
329 call gettkn(line,token,lth)
330 end if
331 c
332 c----------------------------------------------------------------------
333 c Check for a closing parenthesis (actually, this is optional)
334 c----------------------------------------------------------------------
335 if (token.eq.')') call gettkn(line,token,lth)
336 c
337 c----------------------------------------------------------------------
338 c No '(' found: index is 0
339 c----------------------------------------------------------------------
340 else
341 indtkn=0
342 end if
343 c
344 c----------------------------------------------------------------------
345 c Restore last token taken from the line
346 c----------------------------------------------------------------------
347 call ungett(token,lth,line)
348 return
349 c
350 1000 format('*** Illegal index: ''',a,''' ***')
351 end function indtkn
352
stdio::luout
integer, save luout
Definition: stdio.f90:32
stdio::lucmd
integer, save lucmd
Definition: stdio.f90:32
indtkn
integer function indtkn(line)
Definition: strutl1.f90:282
wpoll
void FORTRAN() wpoll()
Definition: pltx.c:860
stdio
Definition: stdio.f90:26
gettkn
subroutine gettkn(line, token, lth)
Written for free-form input of parameters for slow-motional calculations. Returns a token consisting ...
Definition: strutl1.f90:75
ftoken
logical function ftoken(token, lth, val)
Definition: strutl1.f90:182
ungett
subroutine ungett(token, lth, line)
Definition: strutl1.f90:165
getlin
logical function getlin(line)
issue a prompt and retreive a line from command stream
Definition: strutl1.f90:32
stdio::lulog
integer, parameter lulog
Definition: stdio.f90:29
stdio::luecho
integer, save luecho
Definition: stdio.f90:32
stdio::luttyo
integer, parameter luttyo
Definition: stdio.f90:29
stdio::luttyi
integer, parameter luttyi
Definition: stdio.f90:29
itoken
logical function itoken(token, lth, ival)
Definition: strutl1.f90:248
lprmpt
void FORTRAN() lprmpt(void)
Definition: lprmpt.c:8