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
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
|
C----------------------------------------------------------------------
subroutine ftgcls(iunit,colnum,frow,felem,nelem,nultyp,nulval,
& sray,flgval,anynul,status)
C read an array of character string values from the specified column of
C the table.
C The binary or ASCII table column being read must have datatype 'A'
C This general purpose routine will handle null values in one
C of two ways: if nultyp=1, then undefined array elements will be
C set equal to the input value of NULVAL. Else if nultyp=2, then
C undefined array elements will have the corresponding FLGVAL element
C set equal to .TRUE. If NULTYP=1 and NULVAL=0, then no checks for
C undefined values will be made, for maximum efficiency.
C iunit i fortran unit number
C colnum i number of the column to read from
C frow i first row to read
C felem i first element within row to read
C nelem i number of elements to read
C nultyp i input code indicating how to handle undefined values
C nulval c value that undefined pixels will be set to (if nultyp=1)
C sray c array of data values to be read
C flgval l set .true. if corresponding element undefined (if nultyp=2)
C anynul l set to .true. if any of the returned values are undefined
C status i output error status
C
C written by Wm Pence, HEASARC/GSFC, June 1991
integer iunit,colnum,frow,felem,nelem,nultyp,status
logical flgval(*),anynul
character*(*) sray(*),nulval
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)
character cnull*16, cform*8
common/ft0003/cnull(nf),cform(nf)
C END OF COMMON BLOCK DEFINITIONS-----------------------------------
integer bstart,nulchk,twidth,tread,tcode,offset,repeat
integer ibuff,i1,ntodo,rstart,estart,lennul,strlen,nulfil
character snull*16, crow*9,cp1*9,cp2*9,ccol*4
if (status .gt. 0)return
C check for zero length array
if (nelem .le. 0)return
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 read '//
& 'request is out of range:'//crow//' (FTGCLS).')
return
else if (felem .lt. 1)then
C illegal element number
status=308
write(crow,2000)felem
call ftpmsg('Starting element number for read '//
& 'request is out of range:'//crow//' (FTGCLS).')
return
end if
anynul=.false.
ibuff=bufnum(iunit)
i1=1
C column must be character string data type
tcode=tdtype(colnum+tstart(ibuff))
if (tcode .eq. 16)then
C for ASCII columns, TNULL actually stores the field width
twidth=tnull(colnum+tstart(ibuff))
ntodo=nelem
rstart=frow-1
repeat=trept(colnum+tstart(ibuff))
if (felem .gt. repeat)then
C illegal element number
status=308
write(crow,2000)felem
call ftpmsg('Starting element number for read '//
& 'request is out of range:'//crow//' (FTGCLS).')
return
end if
estart=felem-1
bstart=dtstrt(ibuff)+rstart*rowlen(ibuff)
& +tbcol(colnum+tstart(ibuff))+estart*twidth
else if (tcode .eq. -16)then
C this is a variable length descriptor field
ntodo=1
C read the string length and the starting offset:
call ftgdes(iunit,colnum,frow,twidth,offset,status)
C calc the i/o pointer position for the start of the string
bstart=dtstrt(ibuff)+offset+theap(ibuff)
else
C error: not a character string column
status=309
call ftpmsg('Cannot to read character string'//
& ' from a non-character column of a table (FTGCLS).')
return
end if
C define the max. number of charcters to be read: either
C the length of the variable length field, or the length
C of the character string variable, which ever is smaller
strlen=len(sray(1))
tread=min(twidth,strlen)
C move the i/o pointer to the start of the sequence of pixels
call ftmbyt(iunit,bstart,.false.,status)
if (status .gt. 0)then
call ftpmsg('Failed to move to starting position '//
& 'to read character string(s) (FTGCLS).')
return
end if
lennul=0
C determine if we have to check for null values
if (nultyp .eq. 1 .and. nulval .eq. ' ')then
C user doesn't want to check for nulls
nulchk=0
else
nulchk=nultyp
snull=cnull(colnum+tstart(ibuff))
C lennul = length of the string to check for null values
lennul=min(len(sray(1)),8)
end if
C process one string at a time
20 continue
C get the string of characters
sray(i1)=' '
call ftgcbf(iunit,1,tread,sray(i1),status)
if (status .gt. 0)return
C check for null value, if required
if (nulchk .ne. 0)then
if (ichar(sray(i1)(1:1)) .eq. 0 .or.
& sray(i1)(1:lennul) .eq. snull(1:lennul))then
if (nulchk .eq. 1)then
sray(i1)=nulval
anynul=.true.
else
flgval(i1)=.true.
anynul=.true.
end if
end if
end if
C check for null terminated string; pad out with blanks if found
nulfil=index(sray(i1),char(0))
if (nulfil .gt. 1)then
sray(i1)(nulfil:len(sray(1)))=' '
end if
if (status .gt. 0)then
write(cp1,2000)i1
write(ccol,2001)colnum
2001 format(i4)
write(cp1,2000)rstart+1
write(cp2,2000)estart+1
if (felem .eq. 1)then
call ftpmsg('Error while reading ASCII string from '//
& 'column'//ccol//', row'//cp1//' (FTGCLS).')
else
call ftpmsg('Error reading string from '//
& 'column'//ccol//', row'//cp1
& //', element'//cp2//' (FTGCLS).')
end if
return
end if
C find number of pixels left to do, and quit if none left
ntodo=ntodo-1
if (ntodo .gt. 0)then
C increment the pointers
i1=i1+1
estart=estart+1
if (estart .eq. repeat)then
rstart=rstart+1
estart=0
end if
C move to the start of the next string; need to do
C this every time in case we didn't read all the characters
C from the previous string.
bstart=dtstrt(ibuff)+rstart*rowlen(ibuff)
& +tbcol(colnum+tstart(ibuff))+estart*twidth
C move the i/o pointer
call ftmbyt(iunit,bstart,.false.,status)
go to 20
end if
end
|
