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
|
C----------------------------------------------------------------------
subroutine ftgphx(iunit,maxdim,simple,bitpix,naxis,naxes,pcount
& ,gcount,extend,bscale,bzero,blank,nblank,status)
C get the main primary header keywords which define the array structure
C
C iunit i fortran unit number to use for reading
C maxdim i maximum no. of dimensions to read; dimension of naxes
C OUTPUT PARAMETERS:
C simple l does file conform to FITS standard?
C bitpix i number of bits per data value
C naxis i number of axes in the data array
C naxes i array giving the length of each data axis
C pcount i number of group parameters (usually 0)
C gcount i number of random groups (usually 1 or 0)
C extend l may extensions be present in the FITS file?
C bscale d scaling factor
C bzero d scaling zero point
C blank i value used to represent undefined pixels
C nblank i number of trailing blank keywords immediately before the END
C status i output error status (0=OK)
C
C written by Wm Pence, HEASARC/GSFC, June 1991
integer iunit,maxdim,bitpix,naxis
integer naxes(*),pcount,gcount,blank,status,tstat
logical simple,extend,unknow
character keynam*8,value*20,lngval*40,comm*72,extn*4,keybuf*80
double precision bscale,bzero
integer nkey,nblank,i,ibuff,taxes,maxd
C COMMON BLOCK DEFINITIONS:--------------------------------------------
integer nb,ne
parameter (nb = 20)
parameter (ne = 200)
integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
integer nxtfld
logical wrmode
common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
& wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C END OF COMMON BLOCK DEFINITIONS-----------------------------------
if (status .gt. 0)return
ibuff=bufnum(iunit)
C check that the first keyword is valid
call ftgrec(iunit,1,keybuf,status)
keynam=keybuf(1:8)
C parse the value and comment fields from the record
call ftpsvc(keybuf,value,comm,status)
if (status .gt. 0)go to 900
simple=.true.
unknow=.false.
if (chdu(ibuff) .eq. 1)then
if (keynam .eq. 'SIMPLE')then
if (value .eq. 'F')then
C this is not a simple FITS file; try to process it anyway
simple=.false.
else if (value .ne. 'T')then
C illegal value for the SIMPLE keyword
status=220
if (keybuf(9:10) .ne. '= ')then
call ftpmsg('The SIMPLE keyword is missing "= " in '//
& 'columns 9-10.')
else
call ftpmsg('The SIMPLE keyword value is illegal:'//value
& // '. It must equal T or F:')
end if
call ftpmsg(keybuf)
end if
else
status=221
call ftpmsg('First keyword of the file is not SIMPLE: '//keynam)
call ftpmsg(keybuf)
go to 900
end if
else
if (keynam .eq. 'XTENSION')then
if (value(2:9) .ne. 'IMAGE ' .and.
& value(2:9) .ne. 'IUEIMAGE')then
C I don't know what type of extension this is, but press on
unknow=.true.
if (keybuf(9:10) .ne. '= ')then
call ftpmsg('The XTENSION keyword is missing "= " in '//
& 'columns 9-10.')
else
call ftpmsg('This is not an IMAGE extension: '//value)
end if
call ftpmsg(keybuf)
end if
else
status=225
write(extn,1000)chdu(ibuff)
1000 format(i4)
call ftpmsg('First keyword in extension '//extn//
& ' was not XTENSION: '//keynam)
call ftpmsg(keybuf)
end if
end if
if (status .gt. 0)go to 900
C check that BITPIX is the second keyword
call ftgrec(iunit,2,keybuf,status)
keynam=keybuf(1:8)
C parse the value and comment fields from the record
call ftpsvc(keybuf,value,comm,status)
if (status .gt. 0)go to 900
if (keynam .ne. 'BITPIX')then
status=222
call ftpmsg('Second keyword was not BITPIX: '//keynam)
call ftpmsg(keybuf)
go to 900
end if
C convert character string to integer
call ftc2ii(value,bitpix,status)
if (status .gt. 0)then
C bitpix value must be an integer
if (keybuf(9:10) .ne. '= ')then
call ftpmsg('BITPIX keyword is missing "= "'//
& ' in columns 9-10.')
else
call ftpmsg('Value of BITPIX is not an integer: '//value)
end if
call ftpmsg(keybuf)
status=211
go to 900
end if
C test that bitpix has a legal value
call fttbit(bitpix,status)
if (status .gt. 0)then
call ftpmsg(keybuf)
go to 900
end if
C check that the third keyword is NAXIS
call ftgtkn(iunit,3,'NAXIS',naxis,status)
if (status .eq. 208)then
C third keyword was not NAXIS
status=223
else if (status .eq. 209)then
C NAXIS value was not an integer
status=212
end if
if (status .gt. 0)go to 900
if (maxdim .le. 0)then
maxd=naxis
else
maxd=min(maxdim,naxis)
end if
do 10 i=1,naxis
C construct keyword name
call ftkeyn('NAXIS',i,keynam,status)
C attempt to read the keyword
call ftgtkn(iunit,3+i,keynam,taxes,status)
if (status .gt. 0)then
status=224
go to 900
else if (taxes .lt. 0)then
C NAXISn keywords must not be negative
status=213
go to 900
else if (i .le. maxd)then
naxes(i)=taxes
end if
10 continue
C now look for other keywords of interest: bscale, bzero, blank, and END
C and pcount, gcount, and extend
15 bscale=1.
bzero=0.
pcount=0
gcount=1
extend=.false.
C choose a special value to represent the absence of a blank value
blank=123454321
nkey=3+naxis
18 nblank=0
20 nkey=nkey+1
tstat=status
call ftgrec(iunit,nkey,keybuf,status)
if (status .gt. 0)then
C first, check for normal end-of-header status, and reset to 0
if (status .eq. 203)status=tstat
C if we hit the end of file, then set status = no END card found
if (status .eq. 107)then
status=210
call ftpmsg('FITS header has no END keyword!')
end if
go to 900
end if
keynam=keybuf(1:8)
comm=keybuf(9:80)
if (keynam .eq. 'BSCALE')then
C convert character string to floating pt.
call ftpsvc(keybuf,lngval,comm,status)
call ftc2dd(lngval,bscale,status)
if (status .gt. 0)then
call ftpmsg('Error reading BSCALE keyword value'//
& ' as a Double:'//lngval)
end if
else if (keynam .eq. 'BZERO')then
C convert character string to floating pt.
call ftpsvc(keybuf,lngval,comm,status)
call ftc2dd(lngval,bzero,status)
if (status .gt. 0)then
call ftpmsg('Error reading BZERO keyword value'//
& ' as a Double:'//lngval)
end if
else if (keynam .eq. 'BLANK')then
C convert character string to integer
call ftpsvc(keybuf,value,comm,status)
call ftc2ii(value,blank,status)
if (status .gt. 0)then
call ftpmsg('Error reading BLANK keyword value'//
& ' as an integer:'//value)
end if
else if (keynam .eq. 'PCOUNT')then
C convert character string to integer
call ftpsvc(keybuf,value,comm,status)
call ftc2ii(value,pcount,status)
if (status .gt. 0)then
call ftpmsg('Error reading PCOUNT keyword value'//
& ' as an integer:'//value)
end if
else if (keynam .eq. 'GCOUNT')then
C convert character string to integer
call ftpsvc(keybuf,value,comm,status)
call ftc2ii(value,gcount,status)
if (status .gt. 0)then
call ftpmsg('Error reading GCOUNT keyword value'//
& ' as an integer:'//value)
end if
else if (keynam .eq. 'EXTEND')then
C convert character string to logical
call ftpsvc(keybuf,value,comm,status)
call ftc2ll(value,extend,status)
if (status .gt. 0)then
call ftpmsg('Error reading EXTEND keyword value'//
& ' as a Logical:'//value)
end if
else if (keynam .eq. ' ' .and. comm .eq. ' ')then
C need to ignore trailing blank records before the END card
nblank=nblank+1
go to 20
else if (keynam .eq. 'END')then
go to 900
end if
if (status .gt. 0)go to 900
go to 18
900 continue
if (status .gt. 0)then
if (chdu(ibuff) .eq. 1)then
call ftpmsg('Failed to parse the required keywords in '//
& 'the Primary Array header ')
else
call ftpmsg('Failed to parse the required keywords in '//
& 'the Image Extension header (FTGPHX).')
end if
else if (unknow)then
C set status if this was an unknown type of extension
status=233
end if
end
|
