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
|
C--------------------------------------------------------------------------
subroutine fticol(iunit,numcol,ttype,tform,status)
C insert a new column into an existing table
C iunit i Fortran I/O unit number
C numcol i number (position) for the new column; 1 = first column
C any existing columns will be moved up one position
C ttype c name of column (value for TTYPEn keyword)
C tform c column format (value for TFORMn keyword)
C status i returned error status (0=ok)
integer iunit,numcol,status
character*(*) ttype,tform
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)
C END OF COMMON BLOCK DEFINITIONS-----------------------------------
integer ibuff,colnum,typhdu,datcod,repeat,width,decims,delbyt
integer naxis1,naxis2,size,freesp,nblock,tflds,tbc,fstbyt,i
character comm*70,tfm*30,keynam*8
if (status .gt. 0)return
C define the number of the buffer used for this file
ibuff=bufnum(iunit)
C test that the CHDU is an ASCII table or BINTABLE
typhdu=hdutyp(ibuff)
if (typhdu .ne. 1 .and. typhdu .ne. 2)then
status=235
call ftpmsg('Can only append column to TABLE or '//
& 'BINTABLE extension (FTICOL)')
return
end if
C check that the column number is valid
tflds=tfield(ibuff)
if (numcol .lt. 1)then
status=302
return
else if (numcol .gt. tflds)then
colnum=tflds+1
else
colnum=numcol
end if
C parse the tform value and calc number of bytes to add to each row
C make sure format characters are in upper case:
tfm=tform
call ftupch(tfm)
if (typhdu .eq. 1)then
call ftasfm(tfm,datcod,width,decims,status)
C add one space between the columns
delbyt=width+1
else
call ftbnfm(tfm,datcod,repeat,width,status)
if (datcod .eq. 1)then
C bit column; round up to a multiple of 8 bits
delbyt=(repeat+7)/8
else if (datcod .eq. 16)then
C ASCII string column
delbyt=repeat
else
C numerical data type
delbyt=(datcod/10)*repeat
end if
end if
C quit on error, or if column is zero byte wide (repeat=0)
if (status .gt. 0 .or. delbyt .eq. 0)return
C get current size of the table
naxis1=rowlen(ibuff)
call ftgkyj(iunit,'NAXIS2',naxis2,comm,status)
C Calculate how many more FITS blocks (2880 bytes) need to be added
size=theap(ibuff)+scount(ibuff)
freesp=(delbyt*naxis2) - ((size+2879)/2880)*2880 + size
nblock=(freesp+2879)/2880
C insert the needed number of new FITS blocks at the end of the HDU
if (nblock .gt. 0)call ftiblk(iunit,nblock,1,status)
C shift the heap down, and update pointers to start of heap
size=delbyt*naxis2
call fthpdn(iunit,size,status)
C calculate byte position in the row where to insert the new column
if (colnum .gt. tflds)then
fstbyt=naxis1
else
fstbyt=tbcol(colnum+tstart(ibuff))
end if
C insert DELBYT bytes in every row, at byte position FSTBYT
call ftcins(iunit,naxis1,naxis2,delbyt,fstbyt,status)
if (typhdu .eq. 1)then
C adjust the TBCOL values of the existing columns
do 10 i=1,tflds
call ftkeyn('TBCOL',i,keynam,status)
call ftgkyj(iunit,keynam,tbc,comm,status)
if (tbc .gt. fstbyt)then
tbc=tbc+delbyt
call ftmkyj(iunit,keynam,tbc,'&',status)
end if
10 continue
end if
C update the mandatory keywords
call ftmkyj(iunit,'TFIELDS',tflds+1,'&',status)
call ftmkyj(iunit,'NAXIS1',naxis1+delbyt,'&',status)
C increment the index value on any existing column keywords
call ftkshf(iunit,colnum,tflds,1,status)
C add the required keywords for the new column
comm='label for field'
call ftpkns(iunit,'TTYPE',colnum,1,ttype,comm,status)
comm='format of field'
call ftpkns(iunit,'TFORM',colnum,1,tfm,comm,status)
if (typhdu .eq. 1)then
comm='beginning column of field '
if (colnum .eq. tflds+1)then
C allow for the space between preceding column
tbc=fstbyt+2
else
tbc=fstbyt+1
end if
call ftpknj(iunit,'TBCOL',colnum,1,tbc,comm,status)
end if
C parse the header to initialize the new table structure
call ftrdef(iunit,status)
end
|
