-
Notifications
You must be signed in to change notification settings - Fork 20
/
dfltin.f
297 lines (264 loc) · 8.88 KB
/
dfltin.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
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
SUBROUTINE sla_DFLTIN (STRING, NSTRT, DRESLT, JFLAG)
*+
* - - - - - - -
* D F L T I N
* - - - - - - -
*
* Convert free-format input into double precision floating point
*
* Given:
* STRING c string containing number to be decoded
* NSTRT i pointer to where decoding is to start
* DRESLT d current value of result
*
* Returned:
* NSTRT i advanced to next number
* DRESLT d result
* JFLAG i status: -1 = -OK, 0 = +OK, 1 = null, 2 = error
*
* Notes:
*
* 1 The reason DFLTIN has separate OK status values for +
* and - is to enable minus zero to be detected. This is
* of crucial importance when decoding mixed-radix numbers.
* For example, an angle expressed as deg, arcmin, arcsec
* may have a leading minus sign but a zero degrees field.
*
* 2 A TAB is interpreted as a space, and lowercase characters
* are interpreted as uppercase.
*
* 3 The basic format is the sequence of fields #^.^@#^, where
* # is a sign character + or -, ^ means a string of decimal
* digits, and @, which indicates an exponent, means D or E.
* Various combinations of these fields can be omitted, and
* embedded blanks are permissible in certain places.
*
* 4 Spaces:
*
* . Leading spaces are ignored.
*
* . Embedded spaces are allowed only after +, -, D or E,
* and after the decomal point if the first sequence of
* digits is absent.
*
* . Trailing spaces are ignored; the first signifies
* end of decoding and subsequent ones are skipped.
*
* 5 Delimiters:
*
* . Any character other than +,-,0-9,.,D,E or space may be
* used to signal the end of the number and terminate
* decoding.
*
* . Comma is recognized by DFLTIN as a special case; it
* is skipped, leaving the pointer on the next character.
* See 13, below.
*
* 6 Both signs are optional. The default is +.
*
* 7 The mantissa ^.^ defaults to 1.
*
* 8 The exponent @#^ defaults to D0.
*
* 9 The strings of decimal digits may be of any length.
*
* 10 The decimal point is optional for whole numbers.
*
* 11 A "null result" occurs when the string of characters being
* decoded does not begin with +,-,0-9,.,D or E, or consists
* entirely of spaces. When this condition is detected, JFLAG
* is set to 1 and DRESLT is left untouched.
*
* 12 NSTRT = 1 for the first character in the string.
*
* 13 On return from DFLTIN, NSTRT is set ready for the next
* decode - following trailing blanks and any comma. If a
* delimiter other than comma is being used, NSTRT must be
* incremented before the next call to DFLTIN, otherwise
* all subsequent calls will return a null result.
*
* 14 Errors (JFLAG=2) occur when:
*
* . a +, -, D or E is left unsatisfied; or
*
* . the decimal point is present without at least
* one decimal digit before or after it; or
*
* . an exponent more than 100 has been presented.
*
* 15 When an error has been detected, NSTRT is left
* pointing to the character following the last
* one used before the error came to light. This
* may be after the point at which a more sophisticated
* program could have detected the error. For example,
* DFLTIN does not detect that '1D999' is unacceptable
* (on a computer where this is so) until the entire number
* has been decoded.
*
* 16 Certain highly unlikely combinations of mantissa &
* exponent can cause arithmetic faults during the
* decode, in some cases despite the fact that they
* together could be construed as a valid number.
*
* 17 Decoding is left to right, one pass.
*
* 18 See also FLOTIN and INTIN
*
* Called: sla__IDCHF
*
* P.T.Wallace Starlink 18 March 1999
*
* Copyright (C) 1999 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
CHARACTER*(*) STRING
INTEGER NSTRT
DOUBLE PRECISION DRESLT
INTEGER JFLAG
INTEGER NPTR,MSIGN,NEXP,NDP,NVEC,NDIGIT,ISIGNX,J
DOUBLE PRECISION DMANT,DIGIT
* Current character
NPTR=NSTRT
* Set defaults: mantissa & sign, exponent & sign, decimal place count
DMANT=0D0
MSIGN=1
NEXP=0
ISIGNX=1
NDP=0
* Look for sign
100 CONTINUE
CALL sla__IDCHF(STRING,NPTR,NVEC,NDIGIT,DIGIT)
GO TO ( 400, 100, 800, 500, 300, 200, 9110, 9100, 9110),NVEC
* 0-9 SP D/E . + - , ELSE END
* Negative
200 CONTINUE
MSIGN=-1
* Look for first leading decimal
300 CONTINUE
CALL sla__IDCHF(STRING,NPTR,NVEC,NDIGIT,DIGIT)
GO TO ( 400, 300, 800, 500, 9200, 9200, 9200, 9200, 9210),NVEC
* 0-9 SP D/E . + - , ELSE END
* Accept leading decimals
400 CONTINUE
DMANT=DMANT*1D1+DIGIT
CALL sla__IDCHF(STRING,NPTR,NVEC,NDIGIT,DIGIT)
GO TO ( 400, 1310, 900, 600, 1300, 1300, 1300, 1300, 1310),NVEC
* 0-9 SP D/E . + - , ELSE END
* Look for decimal when none preceded the point
500 CONTINUE
CALL sla__IDCHF(STRING,NPTR,NVEC,NDIGIT,DIGIT)
GO TO ( 700, 500, 9200, 9200, 9200, 9200, 9200, 9200, 9210),NVEC
* 0-9 SP D/E . + - , ELSE END
* Look for trailing decimals
600 CONTINUE
CALL sla__IDCHF(STRING,NPTR,NVEC,NDIGIT,DIGIT)
GO TO ( 700, 1310, 900, 1300, 1300, 1300, 1300, 1300, 1310),NVEC
* 0-9 SP D/E . + - , ELSE END
* Accept trailing decimals
700 CONTINUE
NDP=NDP+1
DMANT=DMANT*1D1+DIGIT
GO TO 600
* Exponent symbol first in field: default mantissa to 1
800 CONTINUE
DMANT=1D0
* Look for sign of exponent
900 CONTINUE
CALL sla__IDCHF(STRING,NPTR,NVEC,NDIGIT,DIGIT)
GO TO (1200, 900, 9200, 9200, 1100, 1000, 9200, 9200, 9210),NVEC
* 0-9 SP D/E . + - , ELSE END
* Exponent negative
1000 CONTINUE
ISIGNX=-1
* Look for first digit of exponent
1100 CONTINUE
CALL sla__IDCHF(STRING,NPTR,NVEC,NDIGIT,DIGIT)
GO TO (1200, 1100, 9200, 9200, 9200, 9200, 9200, 9200, 9210),NVEC
* 0-9 SP D/E . + - , ELSE END
* Use exponent digit
1200 CONTINUE
NEXP=NEXP*10+NDIGIT
IF (NEXP.GT.100) GO TO 9200
* Look for subsequent digits of exponent
CALL sla__IDCHF(STRING,NPTR,NVEC,NDIGIT,DIGIT)
GO TO (1200, 1310, 1300, 1300, 1300, 1300, 1300, 1300, 1310),NVEC
* 0-9 SP D/E . + - , ELSE END
* Combine exponent and decimal place count
1300 CONTINUE
NPTR=NPTR-1
1310 CONTINUE
NEXP=NEXP*ISIGNX-NDP
* Skip if net exponent negative
IF (NEXP.LT.0) GO TO 1500
* Positive exponent: scale up
1400 CONTINUE
IF (NEXP.LT.10) GO TO 1410
DMANT=DMANT*1D10
NEXP=NEXP-10
GO TO 1400
1410 CONTINUE
IF (NEXP.LT.1) GO TO 1600
DMANT=DMANT*1D1
NEXP=NEXP-1
GO TO 1410
* Negative exponent: scale down
1500 CONTINUE
IF (NEXP.GT.-10) GO TO 1510
DMANT=DMANT/1D10
NEXP=NEXP+10
GO TO 1500
1510 CONTINUE
IF (NEXP.GT.-1) GO TO 1600
DMANT=DMANT/1D1
NEXP=NEXP+1
GO TO 1510
* Get result & status
1600 CONTINUE
J=0
IF (MSIGN.EQ.1) GO TO 1610
J=-1
DMANT=-DMANT
1610 CONTINUE
DRESLT=DMANT
* Skip to end of field
1620 CONTINUE
CALL sla__IDCHF(STRING,NPTR,NVEC,NDIGIT,DIGIT)
GO TO (1720, 1620, 1720, 1720, 1720, 1720, 9900, 1720, 9900),NVEC
* 0-9 SP D/E . + - , ELSE END
1720 CONTINUE
NPTR=NPTR-1
GO TO 9900
* Exits
* Null field
9100 CONTINUE
NPTR=NPTR-1
9110 CONTINUE
J=1
GO TO 9900
* Errors
9200 CONTINUE
NPTR=NPTR-1
9210 CONTINUE
J=2
* Return
9900 CONTINUE
NSTRT=NPTR
JFLAG=J
END