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
|
C--------------------------------------------------------------------------
subroutine ftiblk(ounit,nblock,hdrdat,status)
C insert a 2880-byte block at the end of the current header or data.
C ounit i fortran output unit number
C nblock i number of blocks to insert
C hdrdat i insert space in header (0) or data (1)
C status i returned error status (0=ok)
integer ounit,nblock,hdrdat,status
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
character*1 buff(2880,2)
common/ftheap/buff
C END OF COMMON BLOCK DEFINITIONS:------------------------------------
integer ibuff,ipoint,jpoint,i,tstat,thdu,nshift,in,out,tin
character*1 cfill
if (status .gt. 0)return
tstat=status
C get the number of the data buffer used for this unit
ibuff=bufnum(ounit)
C set the appropriate fill value
if (hdrdat .eq. 0 .or. hdutyp(ibuff) .eq. 1)then
C fill header or ASCII table with space
cfill=char(32)
else
C fill with Null (0) in image or bintable data area
cfill=char(0)
end if
C find position in file to insert new block
if (hdrdat .eq. 0)then
ipoint=dtstrt(ibuff)
else
ipoint=hdstrt(ibuff,chdu(ibuff)+1)
end if
if (nblock .eq. 1 .and. hdrdat .eq. 0)then
C******************************************************************
C Don't use this algoritm, even though it may be faster (but initial
C tests showed it didn't make any difference on a SUN) because it is
C less safe than the other more general algorithm. If there is
C not enough disk space available for the added block, this faster
C algorithm won't fail until it tries to move the last block, thus leaving
C the FITS file in a corrupted state. The other more general
C algorithm tries to add a new empty block to the file as the
C first step. If this fails, it still leaves the current FITS
C file unmodified, which is better for the user.
C******************************************************************
C (Note added later:)
C Will use this algorithm anyway when inserting one block in a FITS
C header because the more general algorithm results in a status=252 error
C in cases where the number of rows in a table has not yet been defined
C******************************************************************
C use this more efficient algorithm if just adding a single block
C initialize the first buffer
do 5 i=1,2880
buff(i,1)=cfill
5 continue
in=2
out=1
C move to the read start position
10 call ftmbyt(ounit,ipoint,.false.,status)
C read one 2880-byte FITS logical record into the input buffer
call ftgcbf(ounit,0,2880,buff(1,in),status)
C check for End-Of-File
if (status .eq. 107)go to 20
C move back to the write start postion
call ftmbyt(ounit,ipoint,.false.,status)
C write the 2880-byte FITS logical record stored in the output buffer
call ftpcbf(ounit,0,2880,buff(1,out),status)
C check for error during write (the file may not have write access)
if (status .gt. 0)return
C swap the input and output buffer pointers and move to next block
tin=in
in=out
out=tin
ipoint=ipoint+2880
C now repeat the process until we reach the End-Of-File
go to 10
C we have reached the end of file; now append the last block
20 status=tstat
C move back to the write start postion
call ftmbyt(ounit,ipoint,.true.,status)
C write the 2880-byte FITS logical record stored in the output buffer
call ftpcbf(ounit,0,2880,buff(1,out),status)
else
C use this general algorithm for adding arbitrary number of blocks
C first, find the end of file
thdu=chdu(ibuff)
30 call ftmahd(ounit,maxhdu(ibuff)+1,i,status)
if (status .eq. 107)then
status=tstat
C move back to the current extension
call ftmahd(ounit,thdu,i,status)
go to 100
else if (status .le. 0)then
go to 30
else
call ftpmsg('Error while seeking End of File (FTIBLK)')
return
end if
C calculate number of 2880-byte blocks that have to be shifted down
100 continue
nshift=(hdstrt(ibuff,maxhdu(ibuff)+1)-ipoint)/2880
jpoint=hdstrt(ibuff,maxhdu(ibuff)+1)-2880
C move all the blocks, one at a time, starting at end of file and
C working back to the insert position
do 110 i=1,nshift
C move to the read start position
call ftmbyt(ounit,jpoint,.false.,status)
C read one 2880-byte FITS logical record
call ftgcbf(ounit,0,2880,buff,status)
C move forward to the write start postion
call ftmbyt(ounit,jpoint+nblock*2880,.true.,status)
C write the 2880-byte FITS logical record
call ftpcbf(ounit,0,2880,buff,status)
C check for error
if (status .gt. 0)then
call ftpmsg('Error inserting empty FITS block(s) '//
& '(FTIBLK)')
return
end if
jpoint=jpoint-2880
110 continue
do 120 i=1,2880
buff(i,1)=cfill
120 continue
C move back to the write start postion
call ftmbyt(ounit,ipoint,.true.,status)
do 130 i=1,nblock
C write the 2880-byte FITS logical record
call ftpcbf(ounit,0,2880,buff,status)
130 continue
end if
if (hdrdat .eq. 0)then
C recalculate the starting location of the current data unit
dtstrt(ibuff)=dtstrt(ibuff)+2880*nblock
end if
C recalculate the starting location of all subsequent HDUs
do 140 i=chdu(ibuff)+1,maxhdu(ibuff)+1
hdstrt(ibuff,i)=hdstrt(ibuff,i)+2880*nblock
140 continue
if (status .gt. 0)then
call ftpmsg('Error inserting FITS block(s) (FTIBLK)')
end if
end
|
