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
|
SUBROUTINE sla_DBJIN (STRING, NSTRT, DRESLT, J1, J2)
*+
* - - - - - -
* D B J I N
* - - - - - -
*
* Convert free-format input into double precision floating point,
* using DFLTIN but with special syntax extensions.
*
* The purpose of the syntax extensions is to help cope with mixed
* FK4 and FK5 data. In addition to the syntax accepted by DFLTIN,
* the following two extensions are recognized by DBJIN:
*
* 1) A valid non-null field preceded by the character 'B'
* (or 'b') is accepted.
*
* 2) A valid non-null field preceded by the character 'J'
* (or 'j') is accepted.
*
* The calling program is notified of the incidence of either of these
* extensions through an supplementary status argument. The rest of
* the arguments are as for DFLTIN.
*
* Given:
* STRING char string containing field to be decoded
* NSTRT int pointer to 1st character of field in string
*
* Returned:
* NSTRT int incremented
* DRESLT double result
* J1 int DFLTIN status: -1 = -OK
* 0 = +OK
* +1 = null field
* +2 = error
* J2 int syntax flag: 0 = normal DFLTIN syntax
* +1 = 'B' or 'b'
* +2 = 'J' or 'j'
*
* Called: sla_DFLTIN
*
* For details of the basic syntax, see sla_DFLTIN.
*
* P.T.Wallace Starlink 23 November 1995
*
* Copyright (C) 1995 Rutherford Appleton Laboratory
*-
IMPLICIT NONE
CHARACTER*(*) STRING
INTEGER NSTRT
DOUBLE PRECISION DRESLT
INTEGER J1,J2
INTEGER J2A,LENSTR,NA,J1A,NB,J1B
CHARACTER C
* Preset syntax flag
J2A=0
* Length of string
LENSTR=LEN(STRING)
* Pointer to current character
NA=NSTRT
* Attempt normal decode
CALL sla_DFLTIN(STRING,NA,DRESLT,J1A)
* Proceed only if pointer still within string
IF (NA.GE.1.AND.NA.LE.LENSTR) THEN
* See if DFLTIN reported a null field
IF (J1A.EQ.1) THEN
* It did: examine character it stuck on
C=STRING(NA:NA)
IF (C.EQ.'B'.OR.C.EQ.'b') THEN
* 'B' - provisionally note
J2A=1
ELSE IF (C.EQ.'J'.OR.C.EQ.'j') THEN
* 'J' - provisionally note
J2A=2
END IF
* Following B or J, attempt to decode a number
IF (J2A.EQ.1.OR.J2A.EQ.2) THEN
NB=NA+1
CALL sla_DFLTIN(STRING,NB,DRESLT,J1B)
* If successful, copy pointer and status
IF (J1B.LE.0) THEN
NA=NB
J1A=J1B
* If not, forget about the B or J
ELSE
J2A=0
END IF
END IF
END IF
END IF
* Return argument values and exit
NSTRT=NA
J1=J1A
J2=J2A
END
|
