From fa080de7afc95aa1c19a6e6fc0e0708ced2eadc4 Mon Sep 17 00:00:00 2001 From: Joseph Hunkeler Date: Wed, 8 Jul 2015 20:46:52 -0400 Subject: Initial commit --- math/slalib/dfltin.f | 298 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 298 insertions(+) create mode 100644 math/slalib/dfltin.f (limited to 'math/slalib/dfltin.f') diff --git a/math/slalib/dfltin.f b/math/slalib/dfltin.f new file mode 100644 index 00000000..7d514f39 --- /dev/null +++ b/math/slalib/dfltin.f @@ -0,0 +1,298 @@ + SUBROUTINE slDFLI (STRING, NSTRT, DRESLT, JFLAG) +*+ +* - - - - - - - +* D F L I +* - - - - - - - +* +* 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: slICHF +* +* 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., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + 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 slICHF(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 slICHF(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 slICHF(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 slICHF(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 slICHF(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 slICHF(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 slICHF(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 slICHF(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 slICHF(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 -- cgit