mirror of
https://github.com/eddyem/BTA_lib.git
synced 2025-12-06 02:35:20 +03:00
298 lines
8.9 KiB
Fortran
298 lines
8.9 KiB
Fortran
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
|