eddy/BTA_lib
1
0
Fork 0
mirror of https://github.com/eddyem/BTA_lib.git synced 2026-03-21 09:11:08 +03:00
Code Issues Packages Projects Releases Wiki Activity

copy

Browse Source
This commit is contained in:
eddyem
2015-10-27 19:46:19 +03:00
parent 0891300939
commit 6b3ca8a34b
221 changed files with 36460 additions and 3 deletions
Download Patch File Download Diff File Expand all files Collapse all files

297
slalib/dfltin.f Normal file
View File

@@ -0,0 +1,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