/usr/share/gnudatalanguage/astrolib/dbindex.pro is in gdl-astrolib 2018.02.16+dfsg-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
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 208 209 210 211 212 213 214 215 216 217 218 | pro dbindex,items
;+
; NAME:
; DBINDEX
; PURPOSE:
; Procedure to create index file for data base
;
; CALLING SEQUENCE:
; dbindex, [ items ]
;
; OPTIONAL INPUT:
; items - names or numbers of items to be index -- if not supplied,
; then all indexed fields will be processed.
;
; OUTPUT:
; Index file <name>.dbx is created on disk location ZDBASE:
;
; OPERATIONAL NOTES:
; (1) Data base must have been previously opened for update
; by DBOPEN
;
; (2) Only 18 items can be indexed at one time. If the database has
; more than 18 items, then two separate calls to DBINDEX are needed.
; PROCEDURES CALLED:
; DBINDEX_BLK, DB_INFO(), DB_ITEM, DB_ITEM_INFO(), IS_IEEE_BIG()
; HISTORY:
; version 2 D. Lindler Nov 1987 (new db format)
; W. Landsman added optional items parameter Feb 1989
; William Thompson, GSFC/CDS (ARC), 30 May 1994
; Added support for external (IEEE) data format
; Test if machine is bigendian W. Landsman May, 1996
; Change variable name of BYTESWAP to BSWAP W. Thompson Mar, 1997
; Increased number of fields to 15 W. Landsman June, 1997
; Increase number of items to 18 W. Landsman November 1999
; Allow multiple valued (nonstring) index items W. Landsman November 2000
; Use 64 bit integers for V5.2 or later W. Landsman February 2001
; Do not use EXECUTE() for V6.1 or later, improve efficiency
; W. Landsman December 2006
; Automatically enlarge .dbx file if needed, fix major bug in last
; update W. Landsman Dec 2006
; Assume since V6.1 W. Landsman June 2009
; Allow sorted string items W. Landsman October 2009
; Use Swap_Endian_Inplace instead of IEEE_TO_HOST W. Landsman April 2016
;-
;*****************************************************************
On_error,2 ;Return to caller
compile_opt idl2
; Check to see if data base is opened for update
if db_info('UPDATE') EQ 0 then message, $
'Database must be opened for update'
; Extract index items from data base
if N_params() EQ 1 then db_item,items,itnum else begin
nitems = db_info('ITEMS',0)
itnum = indgen(nitems)
endelse
indextype = db_item_info('INDEX',itnum)
indexed = where(indextype, Nindex) ;Select only indexed items
if Nindex LE 0 then begin
message,'Database has no indexed items',/INF
return
endif else if Nindex GT 18 then begin
message,'ERROR - Only 18 items can be indexed at one time',/INF
return
endif
indextype = indextype[indexed]
if N_params() EQ 1 then indexed = itnum[indexed]
; get info on indexed items
nbytes = db_item_info('NBYTES',indexed) ;Number of bytes
idltype = db_item_info('IDLTYPE',indexed) ;IDL type
sbyte = db_item_info('SBYTE',indexed) ;Starting byte
nval = db_item_info('NVALUES',indexed) ;Number of values per entry
; get db info
nentries = db_info('ENTRIES',0)
if nentries EQ 0 then begin
message, 'ERROR - database contains no entries',/INF
return
endif
unit = db_info('UNIT_DBX',0) ;unit number of index file
external = db_info('EXTERNAL',0) ;external format?
bswap = external ? not IS_IEEE_BIG() : 0
; read header info of index file (mapped file)
reclong = assoc(unit,lonarr(2),0)
h = reclong[0] ;first two longwords
if bswap then swap_endian_inplace,h,/swap_if_little
maxentries = h[1] ;max allowed entries
; If necessary, enlarge the size of the .dbx file. All indexed items must
; then be reindexed.
if maxentries lt nentries then begin
message,'Enlarging index (.dbx) file to support ' + $
strtrim(nentries,2) + ' entries',/INF
dbname = db_info('name',0)
dbcreate,dbname,1,maxentry=nentries,external=db_info('external')
dbopen, dbname, 1
nitems = db_info('ITEMS',0)
itnum = indgen(nitems)
endif
nindex2 = h[0] ;number of indexed items
if nindex2 LT nindex then goto, NOGOOD
reclong = assoc(unit,lonarr(7,nindex2),8)
header = reclong[0] ;index header
if bswap then swap_endian_inplace,header,/swap_if_little
hitem = header[0,*] ;indexed item numbers
hindex = header[1,*] ;index type
htype = header[2,*] ;idl data type
hblock = header[3,*] ;starting block of header
sblock = header[4,*] ;starting block of data values
iblock = header[5,*] ;starting block of indices (type=3)
ublock = header[6,*] ;starting block of unsorted data (type=4)
; extract index items...maximum of 18 indexed fields.
list = lindgen(nentries)+1l
dbext_dbf,list,0,sbyte,nbytes*nval,idltype,nval, $
v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15,v16,v17,v18
for i = 0,nindex-1 do begin
;
; place item in variable v
;
v = (scope_varfetch('v' + strtrim(i+1,2)))
pos = where(hitem EQ indexed[i], N_found)
if N_found LE 0 then goto, NOGOOD
pos = pos[0]
if hindex[pos] NE indextype[i] then goto, NOGOOD
if ( idltype[i] EQ 7 ) then v = byte(v)
;
; process according to index type ---------------------------------------
;
reclong = assoc(unit,lonarr(1),(iblock[pos]*512LL))
case indextype[i] of
1: begin ;indexed (unsorted)
datarec = dbindex_blk(unit, sblock[pos], 512, 0, idltype[i])
datarec[0] = bswap ? swap_endian(v,/swap_if_little) : v
end
;
2: begin ;values are already sorted
nb=(nentries+511L)/512 ;number of 512 value blocks
ind=indgen(nb)*512LL ;position at start of each block
sval=v[ind] ;value at start of each block
;
datarec = dbindex_blk(unit, hblock[pos], 512, 0, idltype[i])
datarec[0] = bswap ? swap_endian(sval,/swap_if_little) : sval
;
datarec = dbindex_blk(unit, sblock[pos], 512, 0, idltype[i])
datarec[0] = bswap ? swap_endian(v,/swap_if_little) : v
end
3: begin ; sort item before storage
if idltype[i] EQ 7 then begin
svv = string(v)
sub= bsort(svv)
v = byte(svv[sub])
endif else begin
sub=bsort(v) ;sort values
v=v[sub]
endelse
nb=(nentries+511)/512 ;number of 512 value blocks
ind=l64indgen(nb)*512LL ;position at start of each block
if idltype[i] EQ 7 then sval=v[*,ind] else sval = v[ind]
;value at start of each block
datarec = dbindex_blk(unit, hblock[pos], 512, 0, idltype[i])
datarec[0] = bswap ? swap_endian(sval,/swap_if_little) : sval
;
datarec = dbindex_blk(unit, sblock[pos], 512, 0, idltype[i])
datarec[0] = bswap ? swap_endian(v,/swap_if_little) : v
reclong[0] = bswap ? swap_endian(sub+1,/swap_if_little) : sub+1 ;indices
end
4: begin ; sort item before storage
datarec = dbindex_blk(unit, ublock[pos], 512, 0, idltype[i])
datarec[0] = bswap ? swap_endian(v,/swap_if_little) : v
if idltype[i] EQ 7 then begin
svv = string(v)
sub= bsort(svv)
v = byte(svv[sub])
endif else begin
sub=bsort(v) ;sort values
v=v[sub]
endelse
nb=(nentries+511)/512 ;number of 512 value blocks
ind=l64indgen(nb)*512LL ;position at start of each block
if idltype[i] EQ 7 then sval=v[*,ind] else sval = v[ind]
;value at start of each block
datarec = dbindex_blk(unit, hblock[pos], 512, 0, idltype[i])
datarec[0] = bswap ? swap_endian(sval,/swap_if_little) : sval
;
datarec = dbindex_blk(unit, sblock[pos], 512, 0, idltype[i])
datarec[0] = bswap ? swap_endian(v,/swap_if_little) : v
;
reclong[0] = bswap ?swap_endian(sub+1,/swap_if_little) : sub+1 ;indices
end
endcase
endfor
return
NOGOOD:
print,'DBINDEX-- Inconsistency in .dbh and .dbx file'
print,'Run dbcreate to create a new index file'
return
end
|