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
|
C--------------------------------------------------------------------------
subroutine ftadef(ounit,lenrow,nfield,bcol,tform,nrows,status)
C Ascii table data DEFinition
C define the structure of the ASCII table data unit
C
C ounit i Fortran I/O unit number
C lenrow i length of a row, in characters
C nfield i number of fields in the table
C bcol i starting position of each column, (starting with 1)
C tform C the data format of the column
C nrows i number of rows in the table
C status i output error status (0 = ok)
C
C written by Wm Pence, HEASARC/GSFC, June 1991
integer ounit,lenrow,nfield,bcol(*),nrows,status
character*(*) tform(*)
C COMMON BLOCK DEFINITIONS:--------------------------------------------
integer nb,ne,nf
parameter (nb = 20)
parameter (ne = 200)
parameter (nf = 3000)
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 ibuff,i,j,clen,c2
character ctemp*24, cnum*3,cbcol*10,caxis1*10
if (status .gt. 0)return
ibuff=bufnum(ounit)
if (dtstrt(ibuff) .lt. 0)then
C freeze the header at its current size
call fthdef(ounit,0,status)
if (status .gt. 0)return
end if
hdutyp(ibuff)=1
tfield(ibuff)=nfield
if (nxtfld + nfield .gt. nf)then
C too many columns open at one time; exceeded array dimensions
status=111
return
end if
tstart(ibuff)=nxtfld
nxtfld=nxtfld+nfield
if (nfield .eq. 0)then
C no data; the next HDU begins in the next logical block
hdstrt(ibuff,chdu(ibuff)+1)=dtstrt(ibuff)
scount(ibuff)=0
theap(ibuff)=0
nxheap(ibuff)=0
else
C initialize the table column parameters
clen=len(tform(1))
do 20 i=1,nfield
tscale(i+tstart(ibuff))=1.
tzero(i+tstart(ibuff))=0.
C choose special value to indicate null values are not defined
cnull(i+tstart(ibuff))=char(1)
cform(i+tstart(ibuff))=tform(i)
tbcol(i+tstart(ibuff))=bcol(i)-1
tdtype(i+tstart(ibuff))=16
C the repeat count is always one for ASCII tables
trept(i+tstart(ibuff))=1
C store the width of the field in TNULL
c2=0
do 10 j=2,clen
if (tform(i)(j:j) .ge. '0' .and.
& tform(i)(j:j) .le. '9')then
c2=j
else
go to 15
end if
10 continue
15 continue
if (c2 .eq. 0)then
C no explicit width, so assume width of 1 character
tnull(i+tstart(ibuff))=1
else
call ftc2ii(tform(i)(2:c2),tnull(i+tstart(ibuff))
& ,status)
if (status .gt. 0)then
C error parsing TFORM to determine field width
status=261
ctemp=tform(i)
call ftpmsg('Error parsing TFORM to get field'
& //' width: '//ctemp)
return
end if
end if
C check that column fits within the table
if (tbcol(i+tstart(ibuff))+tnull(i+tstart(ibuff))
& .gt. lenrow .and. lenrow .ne. 0)then
status=236
write(cnum,1000)i
write(cbcol,1001)bcol(i)
write(caxis1,1001)lenrow
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
end if
20 continue
C calculate the start of the next header unit, based on the
C size of the data unit
rowlen(ibuff)=lenrow
hdstrt(ibuff,chdu(ibuff)+1)=
& dtstrt(ibuff)+(lenrow*nrows+2879)/2880*2880
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 ASCII tables have no special data area
scount(ibuff)=0
theap(ibuff)=rowlen(ibuff)*nrows
nxheap(ibuff)=0
end if
end
|
