Screamer Project  V3.3.1
Screamer Structure
 All Files Functions Variables
txt2real.f
Go to the documentation of this file.
1  subroutine text_to_real (text, rvalue, flag)
2 c
3 c Define passed variables
4 c
5  character text*(*)
6  real rvalue
7  integer flag
8 c
9 c ---------------------------------------------------------------------
10 c
11 c Convert text in E- OR F-format to its decimal equivalent, labeled
12 c RVALUE. TEXT must be of the form:
13 c ' (sign)x---x.y----yE(signe)z---z ',
14 c with no embedded blanks. Where 'x,y,z' is a decimal digit.
15 c (sign) and (signe) are '+' (optional) or '-'.
16 c Other valid forms: (decimal point is optional)
17 c (sign)x---x.y---y
18 c (sign)x---x.E(signe)z---z
19 c (sign)x---x.
20 c (sign)x---x
21 c (sign)x---xE(signe)z---z
22 c (sign).y---yE(signe)z---z
23 c (sign).y---y
24 c (sign)E(signe)z---z which is (sign)*10**((signe)*z---z)
25 c An illegal form gives RVALUE=0.0 and FLAG=1.
26 c FLAG=0 if form is allowed.
27 c TEXT has from 1 t0 80 characters.
28 c z---z must be < 28.
29 c -10**9 < x---x < 10**9.
30 c -10**9 < y---y < 10**9 and y---y must be less than 10 digits.
31 c
32 c ---------------------------------------------------------------------
33 c
34 c Modifications:
35 c MLK, 04/28/95, Comment out all write(9,--) error messages
36 c 2014-02-06 RBS: Changed real*4 to real
37 c
38 c ---------------------------------------------------------------------
39 c
40  real*8 rvalue8, frac8, exp8, ten8
41  integer*4 start, end
42  character decpt*1, e*1, plus*1, minus*1, t*1
43  parameter(decpt='.', e='E', plus='+', minus='-')
44  parameter(ten8=10.0)
45  integer*4 error
46  parameter(error = 1, no_error = 0, no_text = 0)
47  parameter(max_exp = 27, max_digits = 9)
48 c
49  flag = no_error
50 c
51 c Strip blanks and return if all blanks
52 c
53  call strip(text, start, end)
54  if (start .eq. no_text) then
55 c write(9,*)'Error 5'
56  go to 999
57  end if
58 c
59 c Set decimal point and 'E' position counters less than zero
60 c
61  idecpt = -2
62  iexp = -1
63 c
64 c Look for decimal point
65 c
66  i = start
67  do while (( i .le. end) .and. (text(i:i) .ne. decpt))
68  i = i + 1
69  end do
70  if (i .le. end) then
71  idecpt = i
72  end if
73 c
74 c Look for 'E' from exponent. Error if it is the last character.
75 c
76  i = start
77  do while ((i .le. end) .and. (text(i:i) .ne. e))
78  i = i + 1
79  end do
80  if (i .lt. end) then
81  iexp = i
82  else if (i .eq. end) then
83 c write(9,*)'Error 6'
84  go to 999
85  end if
86 c
87 c Make sure decimal point is left of 'E' if 'E' exists
88 c
89  if ((iexp .gt. 0) .and. (idecpt .ge. iexp)) then
90 c write(9,*)'Error 7'
91  go to 999
92  end if
93 c
94 c
95 c Evaluate exponent ---
96 c
97 c
98  exp8 = 1.0
99  if (iexp .gt. 0) then
100 c
101 c There is an exponent.
102 c Check to see if there are
103 c any blanks to the left or right in the exponent field.
104 c
105  call strip(text((iexp+1):end), istart_exp, iend_exp)
106  if ((end-iexp-1) .ne. (iend_exp-istart_exp)) then
107 c write(9,*)'Error 8'
108  go to 999
109  end if
110 c
111 c Convert the exponent
112 c
113  call conv_to_int(text((iexp+1):end), ivalue, isign, iflag)
114  if ((iflag .eq. error) .or. (ivalue .gt. max_exp)) then
115 c write(9,*)'Error 9'
116  go to 999
117  end if
118  exp8 = ten8 ** (ivalue*isign)
119 c
120  end if
121 c
122 c
123 c Evaluate fraction ---
124 c
125 c
126  frac8 = 0.0
127  if (idecpt .gt. 0) then
128 c
129 c There is a decimal point.
130 c
131  t = text((idecpt+1):(idecpt+1))
132  if (iexp .gt. 0) then
133 c
134 c There is also an exponent.
135 c
136  if (idecpt .lt. (iexp-1)) then
137 c
138 c The fraction contains more than just a decimal point.
139 c check for + or - as the first fraction character.
140 c Check for leading or trailing blanks, then convert.
141 c
142  if ((t .eq. plus) .or. (t .eq. minus)) then
143 c write(9,*)'Error 10'
144  go to 999
145  end if
146 c
147  call strip(text((idecpt+1):(iexp-1)),
148  & istart_frac, iend_frac)
149  if ((iexp-idecpt-2) .ne. (iend_frac-istart_frac)) then
150 c write(9,*)'Error 11'
151  go to 999
152  end if
153 c
154  call conv_to_int(text((idecpt+1):(iexp-1)),
155  & ifrac, isign, iflag)
156  if (iflag .eq. error) then
157 c write(9,*)'Error 12'
158  go to 999
159  end if
160 c
161  num_digits = (iexp - idecpt - 1)
162  if (num_digits .gt. max_digits) then
163 c write(9,*)'Error 13'
164  go to 999
165  end if
166  frac8 = dfloat(ifrac) * (ten8 ** (-1*num_digits))
167  end if
168 c
169  else
170 c
171 c or there is no exponent.
172 c
173  if (idecpt .lt. end) then
174 c
175 c There is more than just a decimal point. Check for leading
176 c + or -, leading or trailing blanks, then convert.
177 c
178  if ((t .eq. plus) .or. (t .eq. minus)) then
179 c write(9,*)'Error 14'
180  go to 999
181  end if
182 c
183  call strip(text((idecpt+1):end),
184  & istart_frac, iend_frac)
185  if ((end-idecpt-1) .ne. (iend_frac-istart_frac)) then
186 c write(9,*)'Error 15'
187  go to 999
188  end if
189 c
190  call conv_to_int(text((idecpt+1):end), ifrac, isign,
191  & iflag)
192  if (iflag .eq. error) then
193 c write(9,*)'Error 16'
194  go to 999
195  end if
196 c
197  num_digits = end - idecpt
198  if (num_digits .gt. max_digits) then
199 c write(9,*)'Error 17'
200  go to 999
201  end if
202  frac8 = dfloat(ifrac) * (ten8 ** (-1*num_digits))
203  end if
204 c
205  end if
206 c
207  end if
208 c
209 c
210 c Evaluate integer part ---
211 c
212 c
213  int = 0
214  intsign = +1
215  t = text(start:start)
216  if (idecpt .gt. start) then
217 c
218 c There is a decimal point and an integer field.
219 c
220  if (idecpt .gt. (start+1)) then
221 c
222 c The integer length is > 1. check for leading or trailing blanks
223 c and convert.
224 c
225  idecptm=idecpt - 1
226  call strip(text(start:idecptm),
227  & istart_int, iend_int)
228  if ((idecpt-1-start) .ne. (iend_int-istart_int)) then
229 c write(9,*)'Error 18'
230  go to 999
231  end if
232 c
233  call conv_to_int(text(start:idecptm), int, intsign,
234  & iflag)
235  if (iflag .eq. error) then
236 c write(9,*)'Error 19'
237  go to 999
238  end if
239 c
240  else
241 c
242 c The integer length = 1. So check for sign only.
243 c
244  if (t .eq. plus) then
245  intsign = +1
246  int = 0
247  else if (t .eq. minus) then
248  intsign = -1
249  int = 0
250  else
251  call conv_to_int(t, int, intsign, iflag)
252  if (iflag .eq. error) then
253 c write(9,*)'Error 20'
254  go to 999
255  end if
256  end if
257 c
258  end if
259 c
260  else if (idecpt .eq. start) then
261 c
262 c Number starts with a decimal point.
263 c
264  int = 0
265  intsign = +1
266 c
267  else if (iexp .gt. start) then
268 c
269 c No decimal point, but there is an exponent and an integer length.
270 c
271  if (iexp .gt. (start+1)) then
272 c
273 c Also, the integer length is > 1.
274 c Check for leading or trailing blanks and convert.
275 c
276  call strip(text(start:(iexp-1)), istart_int, iend_int)
277  if ((iexp-1-start) .ne. (iend_int-istart_int)) then
278 c write(9,*)'Error 1'
279  go to 999
280  end if
281 c
282  call conv_to_int(text(start:(iexp-1)), int, intsign, iflag)
283  if (iflag .eq. error) then
284 c write(9,*)'Error 2'
285  go to 999
286  end if
287 c
288  else
289 c
290 c or, the integer length = 1 so check for sign only.
291 c
292  if (t .eq. plus) then
293  intsign = +1
294  int = 1
295  else if (t .eq. minus) then
296  intsign = -1
297  int = 1
298  else
299  call conv_to_int(t, int, intsign, iflag)
300  if (iflag .eq. error) then
301 c write(9,*)'Error 3'
302  go to 999
303  end if
304  end if
305 c
306  end if
307 c
308  else if (iexp .eq. start) then
309 c
310 c There is only an exponent, so integer part = 1.
311 c
312  int = 1
313  intsign = +1
314 c
315  else
316 c
317 c Otherwise there is only an integer part. No exp or dpoint.
318 c Leading and trailing blanks have already been stripped.
319 c
320  call conv_to_int(text(start:end), int, intsign, iflag)
321  if (iflag .eq. error) then
322 c write(9,*)'Error 4'
323  go to 999
324  end if
325 c
326  end if
327 c
328 c Find RVALUE
329 c
330  rvalue8 = (dfloat(int) + frac8) * exp8
331  if (intsign .lt. 0) then
332  rvalue = -sngl(rvalue8)
333  else
334  rvalue = sngl(rvalue8)
335  end if
336  return
337 c
338 c Error
339 c
340  999 continue
341  rvalue = 0.0
342  flag = error
343 c
344  return
345  end
subroutine conv_to_int(text, intmag, intsign, flag)
Definition: cnv2int.f:1
subroutine strip(text, start, end)
Definition: strpblnk.f:1
subroutine text_to_real(text, rvalue, flag)
Definition: txt2real.f:1