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
|
C--------------------------------------------------------------------------
subroutine ftaini(iunit,status)
C initialize the parameters defining the structure of an ASCII table
C iunit i Fortran I/O unit number
C OUTPUT PARAMETERS:
C status i returned error status (0=ok)
C
C written by Wm Pence, HEASARC/GSFC, June 1991
integer iunit,status
C-------COMMON BLOCK DEFINITIONS:--------------------------------------------
integer nf,nb,ne
parameter (nb = 20)
parameter (nf = 3000)
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
integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount
integer theap,nxheap
double precision tscale,tzero
common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
& tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb)
& ,theap(nb),nxheap(nb)
character cnull*16, cform*8
common/ft0003/cnull(nf),cform(nf)
C-------END OF COMMON BLOCK DEFINITIONS-----------------------------------
integer nrows,tfld,nkey,ibuff,i,nblank
character keynam*8,value*70,comm*72,rec*80
character cnum*3,cbcol*10,caxis1*10
if (status .gt. 0)return
C define the number of the buffer used for this file
ibuff=bufnum(iunit)
C store the type of HDU (1 = ASCII table extension)
hdutyp(ibuff)=1
C temporarily set the location of the end of the header to a huge number
hdend(ibuff)=2000000000
hdstrt(ibuff,chdu(ibuff)+1)=2000000000
C check that this is a valid ASCII table, and get parameters
call ftgttb(iunit,rowlen(ibuff),nrows,tfld,status)
if (status .gt. 0)go to 900
if (tfld .gt. nf)then
C arrays not dimensioned large enough for this many fields
status=111
call ftpmsg('This ASCII table has too many fields '//
& 'to be read with FITSIO (FTAINI).')
go to 900
end if
C store the number of fields in the common block
tfield(ibuff)=tfld
if (nxtfld + tfld .gt. nf)then
C too many columns open at one time; exceeded array dimensions
status=111
return
end if
tstart(ibuff)=nxtfld
nxtfld=nxtfld+tfld
C initialize the table field parameters
do 5 i=1,tfld
tscale(i+tstart(ibuff))=1.
tzero(i+tstart(ibuff))=0.
C choose special value to indicate that null value is not defined
cnull(i+tstart(ibuff))=char(1)
C pre-set required keyword values to a null value
tbcol(i+tstart(ibuff))=-1
tdtype(i+tstart(ibuff))=-9999
5 continue
C initialize the fictitious heap starting address (immediately following
C the table data) and a zero length heap. This is used to find the
C end of the table data when checking the fill values in the last block.
C there is no special data following an ASCII table
scount(ibuff)=0
theap(ibuff)=rowlen(ibuff)*nrows
nxheap(ibuff)=0
C now read through the rest of the header looking for table column
C definition keywords, and the END keyword.
nkey=8
8 nblank=0
10 nkey=nkey+1
call ftgrec(iunit,nkey,rec,status)
if (status .eq. 107)then
C if we hit the end of file, then set status = no END card found
status=210
call ftpmsg('Required END keyword not found in ASCII table'//
& ' header (FTAINI).')
go to 900
else if (status .gt. 0)then
go to 900
end if
keynam=rec(1:8)
comm=rec(9:80)
if (keynam(1:1) .eq. 'T')then
C get the ASCII table parameter (if it is one)
call ftpsvc(rec,value,comm,status)
call ftgatp(ibuff,keynam,value,status)
else if (keynam .eq. ' ' .and. comm .eq. ' ')then
nblank=nblank+1
go to 10
else if (keynam .eq. 'END')then
go to 20
end if
go to 8
20 continue
C test that all the required keywords were found
do 25 i=1,tfld
if (tbcol(i+tstart(ibuff)) .eq. -1)then
status=231
call ftkeyn('TBCOL',i,keynam,status)
call ftpmsg('Required '//keynam//
& ' keyword not found (FTAINI).')
return
else if (tbcol(i+tstart(ibuff)) .lt. 0 .or.
& tbcol(i+tstart(ibuff)) .ge. rowlen(ibuff)
& .and. rowlen(ibuff) .ne. 0)then
status=234
call ftkeyn('TBCOL',i,keynam,status)
call ftpmsg('Value of the '//keynam//
& ' keyword is out of range (FTAINI).')
return
C check that column fits within the table
else if (tbcol(i+tstart(ibuff))+tnull(i+tstart(ibuff)) .gt.
& rowlen(ibuff) .and. rowlen(ibuff) .ne. 0)then
status=236
write(cnum,1000)i
write(cbcol,1001)tbcol(i+tstart(ibuff))+1
write(caxis1,1001)rowlen(ibuff)
1000 format(i3)
1001 format(i10)
call ftpmsg('Column '//cnum//' will not fit '//
& 'within the specified width of the ASCII table.')
call ftpmsg('TFORM='//cform(i+tstart(ibuff))//
& ' TBCOL='//cbcol//' NAXIS1='//caxis1)
return
else if (tdtype(i+tstart(ibuff)) .eq. -9999)then
status=232
call ftkeyn('TFORM',i,keynam,status)
call ftpmsg('Required '//keynam//
& ' keyword not found (FTAINI).')
return
end if
25 continue
C now we know everything about the table; just fill in the parameters:
C the 'END' record begins 80 bytes before the current position,
C ignoring any trailing blank keywords just before the END keyword
hdend(ibuff)=nxthdr(ibuff)-80*(nblank+1)
C the data unit begins at the beginning of the next logical block
dtstrt(ibuff)=((nxthdr(ibuff)-80)/2880+1)*2880
C reset header pointer to the first keyword
nxthdr(ibuff)=hdstrt(ibuff,chdu(ibuff))
C the next HDU begins in the next logical block after the data
hdstrt(ibuff,chdu(ibuff)+1)=
& dtstrt(ibuff)+(rowlen(ibuff)*nrows+2879)/2880*2880
900 continue
end
|
