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
|
C--------------------------------------------------------------------------
subroutine ftdrow(iunit,frow,nrows,status)
C delete NROWS rows from a table, beginning with row FROW
C iunit i Fortran I/O unit number
C frow i row number after which the new rows will be inserted.
C Specify 0 to add rows to the beginning of the table.
C nrows i number of rows to add to the table (must be greater than 0)
C status i returned error status (0=ok)
integer iunit,frow,nrows,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)
C END OF COMMON BLOCK DEFINITIONS-----------------------------------
integer ibuff,naxis1,naxis2,size,freesp,nblock,row
character comm*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
if (hdutyp(ibuff) .ne. 1 .and. hdutyp(ibuff) .ne. 2)then
status=235
call ftpmsg('Can only delete rows from TABLE or '//
& 'BINTABLE extension (FTDROW)')
return
end if
C get current size of the table
call ftgkyj(iunit,'NAXIS1',naxis1,comm,status)
call ftgkyj(iunit,'NAXIS2',naxis2,comm,status)
if (nrows .lt. 0)then
status=306
call ftpmsg('Cannot delete negative number of ' //
& 'rows in the table (FTDROW)')
return
else if (frow+nrows-1 .gt. naxis2)then
status=307
call ftpmsg('Specified number of rows to delete '
& //'exceeds number of rows in table (FTDROW)')
return
else if (nrows .eq. 0)then
return
else if (frow .gt. naxis2)then
status=307
call ftpmsg('First row to delete is greater'//
& ' than the number of rows in the table (FTDROW)')
return
else if (frow .le. 0)then
status=307
call ftpmsg('Delete starting row number is less '
& //'than 1 (FTDROW)')
return
end if
C Calculate how many FITS blocks (2880 bytes) need to be deleted
size=theap(ibuff)+scount(ibuff)
freesp=((size+2879)/2880)*2880 - size + naxis1*nrows
nblock=freesp/2880
C shift the rows up
row=frow+nrows
call ftrwup(iunit,row,naxis2,nrows,status)
C shift the heap up
size=naxis1*nrows
call fthpup(iunit,size,status)
if (nblock .gt. 0)call ftdblk(iunit,nblock,1,status)
C update the NAXIS2 keyword
naxis2=naxis2-nrows
call ftmkyj(iunit,'NAXIS2',naxis2,'&',status)
end
|
