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 ftpclx(iunit,colnum,frow,fbit,nbit,lray,status)
C write an array of logical values to a specified bit or byte
C column of the binary table. If the LRAY parameter is .true.,
C then the corresponding bit is set to 1, otherwise it is set
C to 0.
C The binary table column being written to must have datatype 'B'
C or 'X'.
C iunit i fortran unit number
C colnum i number of the column to write to
C frow i first row to write
C fbit i first bit within the row to write
C nbit i number of bits to write
C lray l array of logical data values corresponding to the bits
C to be written
C status i output error status
C
C written by Wm Pence, HEASARC/GSFC, Mar 1992
C modified by Wm Pence May 1992 to remove call to system dependent
C bit testing and setting routines.
integer iunit,colnum,frow,fbit,nbit,status
logical lray(*)
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 bstart,offset,tcode,fbyte,bitloc,ndone,tstat
integer ibuff,i,ntodo,repeat,rstart,estart,buffer
logical descrp,wrbit(8),setbit(8)
character*1 cbuff
character crow*9
if (status .gt. 0)return
ibuff=bufnum(iunit)
tcode=tdtype(colnum+tstart(ibuff))
C check input parameters
if (nbit .le. 0)then
return
else if (frow .lt. 1)then
C error: illegal first row number
status=307
write(crow,2000)frow
2000 format(i9)
call ftpmsg('Starting row number for table write '//
& 'request is out of range:'//crow//' (FTPCLX).')
return
else if (fbit .lt. 1)then
C illegal element number
status=308
write(crow,2000)fbit
call ftpmsg('Starting element number for write '//
& 'request is out of range:'//crow//' (FTPCLX).')
return
end if
fbyte=(fbit+7)/8
bitloc=fbit-(fbit-1)/8*8
ndone=0
ntodo=nbit
rstart=frow-1
estart=fbyte-1
if (tcode .eq. 11)then
descrp=.false.
C N.B: REPEAT is the number of bytes, not number of bits
repeat=trept(colnum+tstart(ibuff))
if (fbyte .gt. repeat)then
C illegal element number
status=308
write(crow,2000)fbit
call ftpmsg('Starting element number for write '//
& 'request is out of range:'//crow//' (FTPCLX).')
return
end if
C calc the i/o pointer location to start of sequence of pixels
bstart=dtstrt(ibuff)+rstart*rowlen(ibuff)+
& tbcol(colnum+tstart(ibuff))+estart
else if (tcode .eq. -11)then
C this is a variable length descriptor column
descrp=.true.
C only bit arrays (tform = 'X') are supported for variable
C length arrays. REPEAT is the number of BITS in the array.
repeat=estart+ntodo
offset=nxheap(ibuff)
C write the number of elements and the starting offset:
call ftpdes(iunit,colnum,frow,repeat,
& offset,status)
C calc the i/o pointer location to start of sequence of pixels
bstart=dtstrt(ibuff)+offset+
& theap(ibuff)+estart
C increment the empty heap starting address (in bytes):
repeat=(repeat+7)/8
nxheap(ibuff)=nxheap(ibuff)+repeat
else
C column must be byte or bit data type
status=310
return
end if
C move the i/o pointer to the start of the pixel sequence
call ftmbyt(iunit,bstart,.true.,status)
tstat=0
C read the next byte (we may only be modifying some of the bits)
20 call ftgcbf(iunit,0,1,cbuff,status)
if (status .eq. 107)then
C hit end of file trying to read the byte, so just set byte = 0
status=tstat
cbuff=char(0)
end if
buffer=ichar(cbuff)
if (buffer .lt. 0)buffer=buffer+256
C move back, to be able to overwrite the byte
call ftmbyt(iunit,bstart,.true.,status)
C reset flags indicating which bits are to be set
wrbit(1)=.false.
wrbit(2)=.false.
wrbit(3)=.false.
wrbit(4)=.false.
wrbit(5)=.false.
wrbit(6)=.false.
wrbit(7)=.false.
wrbit(8)=.false.
C flag the bits that are to be set
do 10 i=bitloc,8
wrbit(i)=.true.
ndone=ndone+1
if(lray(ndone))then
setbit(i)=.true.
else
setbit(i)=.false.
end if
if (ndone .eq. ntodo)go to 100
10 continue
C set or reset the bits within the byte
call ftpbit(setbit,wrbit,buffer)
C write the new byte
cbuff=char(buffer)
call ftpcbf(iunit,0,1,cbuff,status)
C not done, so get the next byte
bstart=bstart+1
if (.not. descrp)then
estart=estart+1
if (estart .eq. repeat)then
C move the i/o pointer to the next row of pixels
estart=0
rstart=rstart+1
bstart=dtstrt(ibuff)+rstart*rowlen(ibuff)+
& tbcol(colnum+tstart(ibuff))+estart
call ftmbyt(iunit,bstart,.true.,status)
end if
end if
bitloc=1
go to 20
100 continue
C set or reset the bits within the byte
call ftpbit(setbit,wrbit,buffer)
C write the new byte
cbuff=char(buffer)
call ftpcbf(iunit,0,1,cbuff,status)
end
|
